(FILECREATED "20-Nov-84 13:38:01" {AZTEC}<TRILLIUM>BIRTHDAY84>RERELEASE>TRI-CREATE.;3 28994
changes to: (FNS GET.BITMAP.NAME.MENU ACQUIRE.CLASS.NAME)
previous date: "19-Nov-84 18:53:33" {AZTEC}<TRILLIUM>BIRTHDAY84>RERELEASE>TRI-CREATE.;2)
(* Copyright (c) 1984 by Xerox Corporation)
(PRETTYCOMPRINT TRI-CREATECOMS)
(RPAQQ TRI-CREATECOMS ((FNS ACQUIRE.CLASS.NAME ACQUIRE.FRAME.NAME ACQUIRE.INTERFACE.NAME ACQUIRE.ITEM
ACQUIRE.ITEM.FROM ACQUIRE.ITEM.TYPE ACQUIRE.ITEM.TYPE.SIMPLE
ACQUIRE.MOVED.LOCATION ACQUIRE.MOVED.PLACEMENT ACQUIRE.MOVED.POSITION
ACQUIRE.NAME ACQUIRE.NAMED.ITEM.FROM ACQUIRE.PLACEMENT ACQUIRE.POSITION
ACQUIRE.REGION ACQUIRE.REGION.GETREGIONFN CREATE.COLOR.NAME
CREATE.INTEGER CREATE.ITEM CREATE.LIST CREATE.OBJECT CREATE.ONEOF
CREATE.STRUCTURE FLIP.ENCLOSED.BOX GET.BITMAP.NAME.MENU GETPOINTONGRID
GETREGIONONGRID HITS.IN.FRAME MENU.ITEM.GREATER VERTICAL.SORT)))
(DEFINEQ
(ACQUIRE.CLASS.NAME
[LAMBDA (INTERFACE) (* HaKo "25-Jul-84 16:08")
(PROG (CLASSES CLASS.MENU CLASS)
[SETQ CLASSES (for FRAME in (GET.FIELDQ INTERFACE FRAMES INTERFACE)
join (COPY (GET.FIELDQ FRAME CLASSES]
(SETQ CLASSES (INTERSECTION CLASSES CLASSES))
(SORT CLASSES)
[SETQ CLASSES (NCONC1 CLASSES (QUOTE ("New class" (QUOTE $$NEW.CLASS$$]
(SETQ CLASS.MENU (create MENU
TITLE ← "Frame classes"
ITEMS ← CLASSES
CENTERFLG ← T
CHANGEOFFSETFLG ← T))
(SETQ CLASS (MENU CLASS.MENU))
(RETURN (COND
((EQ CLASS (QUOTE $$NEW.CLASS$$))
(TRILLIUM.PRINTOUT ON PROMPTWINDOW "New class name for frame: ")
(PROMPT.READ))
(T CLASS])
(ACQUIRE.FRAME.NAME
[LAMBDA (INTERFACE) (* DAHJr "12-AUG-83 15:01")
(DECLARE (GLOBALVARS FRAME.NAME.MENU))
[COND
(FRAME.NAME.MENU)
(T (SETQ FRAME.NAME.MENU (KEYWORD.MENU.CREATE (GET.FIELDQ INTERFACE FRAMES INTERFACE)
(FUNCTION FRAME.CLASSES)
(QUOTE (TITLE "Frames" CENTERFLG T))
(FUNCTION FRAME.NAME]
(KEYWORD.MENU.INVOKE FRAME.NAME.MENU])
(ACQUIRE.INTERFACE.NAME
[LAMBDA NIL (* DAHJr "18-JAN-83 14:46")
(DECLARE (GLOBALVARS INTERFACES))
(MENU (create MENU
ITEMS ← INTERFACES
TITLE ← "Interfaces"
CENTERFLG ← T
CHANGEOFFSETFLG ← T])
(ACQUIRE.ITEM
[LAMBDA (FRAME PROMPT FROM.SUPERFRAMES.TOO ITYPE) (* HaKo "25-Jul-84 16:08")
(* * IF YOU MODIFY THIS, LOOK ALSO AT THE FUNCTION PRINT.ITEMS)
(DECLARE (GLOBALVARS CURRENT.DSP LASTMOUSEBUTTONS))
(PROG (ITEM DONE)
(COND
(PROMPT (TRILLIUM.PRINTOUT ON PROMPTWINDOW PROMPT)))
(FLIP.ALL.ITEMS FRAME FROM.SUPERFRAMES.TOO ITYPE)
[until DONE
do (WAITNOBUG)
(WAITBUG)
(COND
[(LASTMOUSESTATE MIDDLE)
(SETQ ITEM (ACQUIRE.NAMED.ITEM.FROM FRAME FROM.SUPERFRAMES.TOO ITYPE))
(COND
(ITEM (FLIP.ALL.ITEMS FRAME FROM.SUPERFRAMES.TOO ITYPE)
(SETQ DONE T]
(T (WAITNOBUG)
(SETQ ITEM (ACQUIRE.ITEM.FROM FRAME FROM.SUPERFRAMES.TOO ITYPE (LASTMOUSEX
CURRENT.DSP)
(LASTMOUSEY CURRENT.DSP)))
(FLIP.ALL.ITEMS FRAME FROM.SUPERFRAMES.TOO ITYPE)
(SETQ DONE T]
(RETURN ITEM])
(ACQUIRE.ITEM.FROM
[LAMBDA (FRAME FROM.SUPERFRAMES.TOO ITYPE XCOORD YCOORD) (* HaKo "25-Jul-84 16:09")
(for ITEM in (HITS.IN.FRAME FRAME FROM.SUPERFRAMES.TOO ITYPE XCOORD YCOORD)
bind (TOPITEM MINITEM MINBOX BOX)
do (SETQ BOX (BOUNDING.BOX ITEM))
(COND
((NULL TOPITEM)
(SETQ TOPITEM ITEM)
(SETQ MINITEM ITEM)
(SETQ MINBOX BOX))
((STRICTLY.ENCLOSESP MINBOX BOX)
(SETQ MINITEM ITEM)
(SETQ MINBOX BOX))
((STRICTLY.ENCLOSESP BOX MINBOX))
(T (TRILLIUM.PRINTOUT ON TRILLIUM.WARNINGS "More than one indicated; taking the top one")
(RETURN TOPITEM)))
finally (RETURN MINITEM])
(ACQUIRE.ITEM.TYPE
[LAMBDA (PROMPT CLASSLIST) (* HaKo "25-Jul-84 16:09")
(DECLARE (GLOBALVARS ITEM.TYPE.MENU ITEM.TYPES))
(AND PROMPT (TRILLIUM.PRINTOUT ON PROMPTWINDOW PROMPT))
[OR ITEM.TYPE.MENU (SETQ ITEM.TYPE.MENU (KEYWORD.MENU.CREATE ITEM.TYPES (FUNCTION
ITEM.TYPE.CLASSES)
(QUOTE (TITLE "Item types" CENTERFLG
T]
(KEYWORD.MENU.INVOKE ITEM.TYPE.MENU])
(ACQUIRE.ITEM.TYPE.SIMPLE
[LAMBDA (FRAME) (* edited: "24-Jun-84 15:22")
(DECLARE (GLOBALVARS ITEM.TYPE.MENU ITEM.TYPES))
[OR ITEM.TYPE.MENU (SETQ ITEM.TYPE.MENU (KEYWORD.MENU.CREATE ITEM.TYPES (FUNCTION
ITEM.TYPE.CLASSES)
(QUOTE (TITLE "Item types" CENTERFLG
T))
(FUNCTION ITEM.TYPE.MENU.ITEM]
(KEYWORD.MENU.INVOKE ITEM.TYPE.MENU])
(ACQUIRE.MOVED.LOCATION
[LAMBDA (ITEM REFERENCE.LOCATION) (* HaKo "10-Aug-84 17:25")
(DECLARE (GLOBALVARS CURRENT.DSP TRILLIUM.GRID.DX TRILLIUM.GRID.DY TRILLIUM.GRID.HALF.DX
TRILLIUM.GRID.HALF.DY TRILLIUM.GRID.X0 TRILLIUM.GRID.Y0))
(OBS "No more grid stuff!")
(PROG ((BOX (COPYALL (COERCE.BOUNDING.BOX ITEM)))
OFFSETX OFFSETY MARKX MARKY LASTX LASTY PREVIOUSX PREVIOUSY)
(SETQ MARKX (XCOORD (CAR REFERENCE.LOCATION)))
(SETQ MARKY (YCOORD (CDR REFERENCE.LOCATION)))
(SETQ OFFSETX (IDIFFERENCE (CAR BOX)
MARKX))
(SETQ OFFSETY (IDIFFERENCE (CADR BOX)
MARKY))
(FLIP.BOX BOX)
(FLIP.SPOT MARKX MARKY)
[while (ZEROP (MOUSEBUTTONS))
do (SETQ LASTX (XGRIDNEAR (LASTMOUSEX CURRENT.DSP)))
(SETQ LASTY (YGRIDNEAR (LASTMOUSEY CURRENT.DSP)))
(COND
((OR (NEQ LASTX PREVIOUSX)
(NEQ LASTY PREVIOUSY))
(FLIP.SPOT MARKX MARKY)
(FLIP.BOX BOX)
(SETQ MARKX (XCOORD LASTX))
(SETQ MARKY (YCOORD LASTY))
(RPLACA BOX (IPLUS MARKX OFFSETX))
(RPLACA (CDR BOX)
(IPLUS MARKY OFFSETY))
(FLIP.BOX BOX)
(FLIP.SPOT MARKX MARKY)
(SETQ PREVIOUSX LASTX)
(SETQ PREVIOUSY LASTY]
(FLIP.SPOT MARKX MARKY)
(FLIP.BOX BOX)
(WAITNOBUG)
(RETURN (CONS LASTX LASTY])
(ACQUIRE.MOVED.PLACEMENT
[LAMBDA (ITEM PROMPT) (* HaKo "13-Aug-84 09:09")
(PROG (ITYPE BOUNDING.BOX CENTER.OF.BOUNDING.BOX REFERENCE.POINT NEW.POSITION)
(AND PROMPT (TRILLIUM.PRINTOUT ON PROMPTWINDOW PROMPT))
(SETQ BOUNDING.BOX (COERCE.BOUNDING.BOX ITEM))
(SETQ REFERENCE.POINT (REGION/CENTER BOUNDING.BOX))
(SETQ NEW.POSITION (ACQUIRE.POSITION BOUNDING.BOX))
(RETURN (VECTOR/FROM.TO REFERENCE.POINT NEW.POSITION])
(ACQUIRE.MOVED.POSITION
[LAMBDA (ITEM REFERENCE.POINT) (* HaKo "10-Aug-84 17:25")
(* DAHJr "17-APR-83 15:16")
(DECLARE (GLOBALVARS CURRENT.DSP LASTMOUSEBUTTONS TRILLIUM.GRID.DX TRILLIUM.GRID.DY
TRILLIUM.GRID.HALF.DX TRILLIUM.GRID.HALF.DY TRILLIUM.GRID.X0
TRILLIUM.GRID.Y0))
(OBS "Superseded by new ACQUIRE.POSITION")
(PROG (BOX MARKX MARKY OFFSETX OFFSETY OFFSETXG OFFSETYG LASTX LASTY LASTKEY PREVIOUSX PREVIOUSY
PREVIOUSKEY DOWN DONE GRID.DRAWN)
(SETQ BOX (COPYALL (COERCE.BOUNDING.BOX ITEM)))
(SETQ MARKX (CAR REFERENCE.POINT))
[SETQ MARKY (COND
((NUMBERP (CDR REFERENCE.POINT)))
(T (CADR REFERENCE.POINT]
(SETQ OFFSETX (IDIFFERENCE (CAR BOX)
MARKX))
(SETQ OFFSETY (IDIFFERENCE (CADR BOX)
MARKY))
(SETQ OFFSETXG (IDIFFERENCE (CAR BOX)
(XGRIDIFY MARKX)))
(SETQ OFFSETYG (IDIFFERENCE (CADR BOX)
(YGRIDIFY MARKY)))
(FLIP.BOX BOX)
(FLIP.SPOT MARKX MARKY)
[until DONE
do (SETQ LASTX (LASTMOUSEX CURRENT.DSP))
(SETQ LASTY (LASTMOUSEY CURRENT.DSP))
(SETQ LASTKEY (KEYDOWNP (QUOTE LSHIFT)))
[COND
(LASTKEY (SETQ LASTX (XGRIDIFY LASTX))
(SETQ LASTY (YGRIDIFY LASTY]
(if (KEYDOWNP (QUOTE CTRL))
then (if (NOT GRID.DRAWN)
then (DRAW.GRID)
(SETQ GRID.DRAWN T))
elseif GRID.DRAWN
then (DRAW.GRID)
(SETQ GRID.DRAWN NIL))
(COND
((OR (NEQ LASTX PREVIOUSX)
(NEQ LASTY PREVIOUSY)
(NEQ LASTKEY PREVIOUSKEY))
(FLIP.SPOT MARKX MARKY)
(FLIP.BOX BOX)
(SETQ MARKX LASTX)
(SETQ MARKY LASTY)
[RPLACA BOX (IPLUS MARKX (COND
(LASTKEY OFFSETXG)
(T OFFSETX]
[RPLACA (CDR BOX)
(IPLUS MARKY (COND
(LASTKEY OFFSETYG)
(T OFFSETY]
(FLIP.BOX BOX)
(FLIP.SPOT MARKX MARKY)
(SETQ PREVIOUSX LASTX)
(SETQ PREVIOUSY LASTY)
(SETQ PREVIOUSKEY LASTKEY)))
(MOUSEBUTTONS)
(COND
((MOUSESTATE (NOT UP))
(SETQ DOWN T))
((AND DOWN (MOUSESTATE UP))
(SETQ DONE T]
(FLIP.SPOT MARKX MARKY)
(FLIP.BOX BOX)
(RETURN (COND
[LASTKEY (CONS (IPLUS LASTX (IDIFFERENCE OFFSETXG OFFSETX))
(IPLUS LASTY (IDIFFERENCE OFFSETYG OFFSETY]
(T (CONS LASTX LASTY])
(ACQUIRE.NAME
[LAMBDA (MESSAGE) (* HaKo "25-Jul-84 16:10")
(COND
(MESSAGE (TRILLIUM.PRINTOUT ON PROMPTWINDOW MESSAGE ": ")))
(PROMPT.READ])
(ACQUIRE.NAMED.ITEM.FROM
[LAMBDA (FRAME SUPERFRAMES.TOO ITYPE) (* HaKo "25-Jul-84 16:10")
(PROG (NAME MENU.ITEMS NAME.MENU)
[SETQ MENU.ITEMS (for ITEM in (GET.FIELDQ FRAME ITEMS)
when [AND (OR (NULL ITYPE)
(EQ ITYPE (ITEM.TYPE ITEM)))
(SETQ NAME (LISTGET ITEM (QUOTE NAME]
collect (LIST NAME (KWOTE ITEM]
(RETURN (COND
(MENU.ITEMS (SETQ MENU.ITEMS (SORT MENU.ITEMS (FUNCTION MENU.ITEM.GREATER)))
[SETQ NAME.MENU (CHUNK.MENU.CREATE MENU.ITEMS
(QUOTE (TITLE "Named items"
CENTERFLG T]
(CHUNK.MENU.INVOKE NAME.MENU))
(T (TRILLIUM.PRINTOUT ON TRILLIUM.WARNINGS "This frame has no named items")
(WAITNOBUG)
NIL])
(ACQUIRE.PLACEMENT
[LAMBDA (ITEM PROMPT) (* HaKo "13-Aug-84 09:26")
(PROG (ITYPE DESCRIPTION PTYPE TRANSLATE.FN CREATE.FN PNAME PVAL (SUB.PROMPT
"Indicate values for the following characteristics: "))
(AND PROMPT (TRILLIUM.PRINTOUT ON PROMPTWINDOW PROMPT))
(SETQ ITYPE (ITEM.TYPE ITEM))
(SETQ DESCRIPTION (ITEM.TYPE.DESCRIPTION ITYPE))
(RETURN (for PARAMETER in (GET.FIELDQ DESCRIPTION PARAMETERS)
when [AND (SETQ PTYPE (LISTP (GET.FIELDQ PARAMETER TYPE)))
(SETQ TRANSLATE.FN (OR (FUNCTION.FOR.PTYPE (CAR PTYPE)
(QUOTE LTRANSLATE))
(FUNCTION.FOR.PTYPE (CAR PTYPE)
(QUOTE TRANSLATE]
collect (SETQ PNAME (GET.FIELDQ PARAMETER NAME))
(SETQ CREATE.FN (FUNCTION.FOR.PTYPE (CAR PTYPE)
(QUOTE CREATE)))
(COND
(SUB.PROMPT (TRILLIUM.PRINTOUT ON PROMPTWINDOW SUB.PROMPT PNAME)
(SETQ SUB.PROMPT))
(T (TRILLIUM.PRINTOUT SAME.LINE ", " PNAME)))
(SETQ PVAL (APPLY* CREATE.FN PTYPE))
(CONS PNAME PVAL])
(ACQUIRE.POSITION
[LAMBDA (OLDPOS BANDFLG WINDOW) (* PH "24-Aug-84 16:18")
(* * This function is supposed to be the bottom call for all fns that need a position. It uses the grid editing
facilities. If OLDPOS is a REGION then its center is assumed to be the intended OLDPOS. If OLDPOS is a POSITION
and BANDFLG=T this function will perform rubber-banding from OLDPOS to cursor. If the LSHIFT key is held down,
position is coerced to be on a grid. If the Control key is held down, the grid is made visible.)
(DECLARE (GLOBALVARS CURRENT.INTERFACE.WINDOW TRILLIUM.GRID.DX TRILLIUM.GRID.DY
TRILLIUM.GRID.HALF.DX TRILLIUM.GRID.HALF.DY TRILLIUM.GRID.X0
TRILLIUM.GRID.Y0))
(OR (WINDOWP WINDOW)
(SETQ WINDOW CURRENT.INTERFACE.WINDOW))
(PROG [NEWPOS X0 Y0 LASTX PREVIOUSX LASTY PREVIOUSY LASTKEY PREVIOUSKEY MARKX MARKY XMAX YMAX
XMIN YMIN XOFFSET YOFFSET BOX GRID.DRAWN CLIPPING.REGION
(DSP (WINDOWPROP WINDOW (QUOTE DSP]
(SETQ CLIPPING.REGION (DSPCLIPPINGREGION NIL DSP))
(SETQ XMIN (fetch (REGION LEFT) of CLIPPING.REGION))
(SETQ XMAX (fetch (REGION RIGHT) of CLIPPING.REGION))
(SETQ YMIN (fetch (REGION BOTTOM) of CLIPPING.REGION))
(SETQ YMAX (fetch (REGION TOP) of CLIPPING.REGION))
(COND
[(NULL OLDPOS)
(MOUSEBUTTONS)
(SETQ NEWPOS (create POSITION
XCOORD ←(LASTMOUSEX DSP)
YCOORD ←(LASTMOUSEY DSP]
[(POSITIONP OLDPOS)
(SETQ NEWPOS (COPYALL OLDPOS))
(if BANDFLG
then (SETQ X0 (fetch (POSITION XCOORD) of NEWPOS))
(SETQ Y0 (fetch (POSITION YCOORD) of NEWPOS]
((REGIONP OLDPOS)
(SETQ BOX (COPYALL OLDPOS))
[SETQ XOFFSET (IMINUS (HALF (fetch (REGION WIDTH) of BOX]
[SETQ YOFFSET (IMINUS (HALF (fetch (REGION HEIGHT) of BOX]
(SETQ XMIN (IDIFFERENCE XMIN XOFFSET))
(SETQ XMAX (IPLUS XMAX XOFFSET))
(SETQ YMIN (IDIFFERENCE YMIN YOFFSET))
(SETQ YMAX (IPLUS YMAX YOFFSET))
(SETQ NEWPOS (REGION/CENTER BOX)))
(T (HELP "Bad type: " OLDPOS)))
(SETQ LASTX (fetch (POSITION XCOORD) of NEWPOS))
(SETQ LASTY (fetch (POSITION YCOORD) of NEWPOS))
(SETQ LASTX (MIN XMAX (MAX XMIN LASTX)))
(SETQ LASTY (MIN YMAX (MAX YMIN LASTY)))
(replace (POSITION XCOORD) of NEWPOS with LASTX)
(replace (POSITION YCOORD) of NEWPOS with LASTY)
(until (ZEROP (MOUSEBUTTONS)) do NIL)
(CURSORPOSITION NEWPOS DSP)
[while (ZEROP (MOUSEBUTTONS))
do (SETQ LASTX (LASTMOUSEX DSP))
(SETQ LASTY (LASTMOUSEY DSP))
[COND
((SETQ LASTKEY (KEYDOWNP (QUOTE LSHIFT)))
(SETQ LASTX (XGRIDIFY LASTX))
(SETQ LASTY (YGRIDIFY LASTY]
(SETQ LASTX (MIN XMAX (MAX XMIN LASTX)))
(SETQ LASTY (MIN YMAX (MAX YMIN LASTY)))
(COND
[(KEYDOWNP (QUOTE CTRL))
(COND
((NOT GRID.DRAWN)
(DRAW.GRID)
(SETQ GRID.DRAWN T]
(GRID.DRAWN (DRAW.GRID)
(SETQ GRID.DRAWN NIL)))
(COND
((OR (NEQ LASTX PREVIOUSX)
(NEQ LASTY PREVIOUSY)
(NEQ LASTKEY PREVIOUSKEY))
[COND
(MARKX (FLIP.SPOT MARKX MARKY)
(COND
(X0 (DRAWLINE X0 Y0 MARKX MARKY 1 (QUOTE INVERT)
CURRENT.DSP))
(BOX (FLIP.BOX BOX]
(SETQ MARKX LASTX)
(SETQ MARKY LASTY)
(replace (POSITION XCOORD) of NEWPOS with MARKX)
(replace (POSITION YCOORD) of NEWPOS with MARKY)
(COND
(X0 (DRAWLINE X0 Y0 MARKX MARKY 1 (QUOTE INVERT)
CURRENT.DSP))
(BOX (replace (REGION LEFT) of BOX with (IPLUS MARKX XOFFSET))
(replace (REGION BOTTOM) of BOX with (IPLUS MARKY YOFFSET))
(FLIP.BOX BOX)))
(FLIP.SPOT MARKX MARKY)
(SETQ PREVIOUSX LASTX)
(SETQ PREVIOUSY LASTY)
(SETQ PREVIOUSKEY LASTKEY]
(FLIP.SPOT MARKX MARKY)
(COND
(X0 (DRAWLINE X0 Y0 MARKX MARKY 1 (QUOTE INVERT)
CURRENT.DSP))
(BOX (FLIP.BOX BOX)))
(COND
(GRID.DRAWN (DRAW.GRID)))
(RETURN NEWPOS])
(ACQUIRE.REGION
[LAMBDA (MINWIDTH MINHEIGHT INITREGION WINDOW) (* HaKo "16-Aug-84 12:59")
(* * This function is supposed to be the bottom call for all fns that need a region. It uses the grid editing
facilities. If the LSHIFT key is held down, position is coerced to be on a grid. If the Control key is held down,
the grid is made visible.)
(* * Old: (* DAHJr "23-JUN-83 17:19") (PROG (NEW.REGION WINDOW WINDOW.OUTLINE WINDOW.BORDER WINDOW.CLIPPING.REGION
TRILLIUM.DELTAX TRILLIUM.DELTAY) (SETQ WINDOW CURRENT.INTERFACE.WINDOW) (SETQ WINDOW.OUTLINE
(WINDOWPROP WINDOW (QUOTE REGION))) (SETQ WINDOW.CLIPPING.REGION (DSPCLIPPINGREGION NIL (WINDOWPROP WINDOW
(QUOTE DSP)))) (SETQ WINDOW.BORDER (WINDOWPROP WINDOW (QUOTE BORDER))) (SETQ TRILLIUM.DELTAX
(IPLUS (MINUS (IPLUS (fetch (REGION LEFT) of WINDOW.OUTLINE) WINDOW.BORDER)) (fetch (REGION LEFT) of
WINDOW.CLIPPING.REGION))) (SETQ TRILLIUM.DELTAY (IPLUS (MINUS (IPLUS (fetch (REGION BOTTOM) of WINDOW.OUTLINE)
WINDOW.BORDER)) (fetch (REGION BOTTOM) of WINDOW.CLIPPING.REGION))) (SETQ NEW.REGION (GETREGION NIL NIL NIL
(FUNCTION ACQUIRE.REGION.GETREGIONFN) (CONS TRILLIUM.DELTAX TRILLIUM.DELTAY))) (RETURN (create REGION LEFT ←
(IPLUS (fetch (REGION LEFT) of NEW.REGION) (MINUS (IPLUS (fetch (REGION LEFT) of WINDOW.OUTLINE) WINDOW.BORDER))
(fetch (REGION LEFT) of WINDOW.CLIPPING.REGION)) BOTTOM ← (IPLUS (fetch (REGION BOTTOM) of NEW.REGION)
(MINUS (IPLUS (fetch (REGION BOTTOM) of WINDOW.OUTLINE) WINDOW.BORDER)) (fetch (REGION BOTTOM) of
WINDOW.CLIPPING.REGION)) WIDTH ← (MAX 4 (fetch (REGION WIDTH) of NEW.REGION)) HEIGHT ← (MAX 4
(fetch (REGION HEIGHT) of NEW.REGION))))))
(DECLARE (GLOBALVARS CURRENT.INTERFACE.WINDOW))
(OR (WINDOWP WINDOW)
(SETQ WINDOW CURRENT.INTERFACE.WINDOW))
(PROG [NEW.REGION MINLEFT MINBOTTOM MAXWIDTH MAXHEIGHT MAXREGION GRID.DRAWN OLDBOX GETREGIONFNARG
(WINDOW.BORDER (WINDOWPROP WINDOW (QUOTE BORDER)))
(WINDOW.OUTLINE (WINDOWPROP WINDOW (QUOTE REGION)))
(CLIPPING.REGION (DSPCLIPPINGREGION NIL (WINDOWPROP WINDOW (QUOTE DSP]
(SETQ MINLEFT (IPLUS WINDOW.BORDER (fetch (REGION LEFT) of WINDOW.OUTLINE)
(fetch (REGION LEFT) of CLIPPING.REGION)))
(SETQ MINBOTTOM (IPLUS WINDOW.BORDER (fetch (REGION BOTTOM) of WINDOW.OUTLINE)
(fetch (REGION BOTTOM) of CLIPPING.REGION)))
(SETQ MAXWIDTH (fetch (REGION WIDTH) of CLIPPING.REGION))
(SETQ MAXHEIGHT (fetch (REGION HEIGHT) of CLIPPING.REGION))
(SETQ MAXREGION (create REGION
LEFT ← MINLEFT
BOTTOM ← MINBOTTOM
WIDTH ← MAXWIDTH
HEIGHT ← MAXHEIGHT))
(SETQ GETREGIONFNARG (LIST GRID.DRAWN OLDBOX MAXREGION))
(SETQ NEW.REGION (GETREGION (SETQ MINWIDTH (MAX 4 (OR MINWIDTH 0)))
(SETQ MINHEIGHT (MAX 4 (OR MINHEIGHT 0)))
(REGIONP INITREGION)
(FUNCTION ACQUIRE.REGION.GETREGIONFN)
GETREGIONFNARG))
(if (SETQ OLDBOX (CADR GETREGIONFNARG))
then (FLIP.BOX OLDBOX))
(if (SETQ GRID.DRAWN (CAR GETREGIONFNARG))
then (DRAW.GRID) (* leftovers *))
(* * NEW.REGION is in screen coordinates, so convert to coordinates of WINDOW)
(RETURN (create REGION
LEFT ←(IDIFFERENCE (fetch (REGION LEFT) of NEW.REGION)
MINLEFT)
BOTTOM ←(IDIFFERENCE (fetch (REGION BOTTOM) of NEW.REGION)
MINBOTTOM)
WIDTH ←(MAX MINWIDTH (fetch (REGION WIDTH) of NEW.REGION))
HEIGHT ←(MAX MINHEIGHT (fetch (REGION HEIGHT) of NEW.REGION])
(ACQUIRE.REGION.GETREGIONFN
[LAMBDA (FIXEDPT MOVINGPT GETREGIONFNARG) (* HaKo "10-Aug-84 16:09")
(* DAHJr "23-Feb-84 14:28")
(* * Old: (COND ((KEYDOWNP (QUOTE LSHIFT)) (GETREGIONONGRID FIXEDPT MOVINGPT DELTAS)) (T (OR MOVINGPT FIXEDPT))))
(DECLARE (GLOBALVARS TRILLIUM.GRID.DX TRILLIUM.GRID.DY TRILLIUM.GRID.HALF.DX
TRILLIUM.GRID.HALF.DY TRILLIUM.GRID.X0 TRILLIUM.GRID.Y0))
(PROG (X XMIN XMAX Y YMIN YMAX (PT (OR MOVINGPT FIXEDPT))
(GRID.DRAWN (CAR GETREGIONFNARG))
(OLDBOX (CADR GETREGIONFNARG))
(MAXREGION (CADDR GETREGIONFNARG)))
(SETQ X (fetch (POSITION XCOORD) of PT))
(SETQ Y (fetch (POSITION YCOORD) of PT))
(SETQ XMIN (fetch (REGION LEFT) of MAXREGION))
(SETQ XMAX (fetch (REGION RIGHT) of MAXREGION))
(SETQ YMIN (fetch (REGION BOTTOM) of MAXREGION))
(SETQ YMAX (fetch (REGION TOP) of MAXREGION))
[if (KEYDOWNP (QUOTE LSHIFT))
then [SETQ X (IPLUS XMIN (XGRIDIFY (MAX 0 (IDIFFERENCE X XMIN]
(SETQ Y (IPLUS YMIN (YGRIDIFY (MAX 0 (IDIFFERENCE Y YMIN]
(if (KEYDOWNP (QUOTE CTRL))
then (if (NOT GRID.DRAWN)
then (DRAW.GRID)
(SETQ GRID.DRAWN T))
elseif GRID.DRAWN
then (if OLDBOX
then (FLIP.BOX OLDBOX))
(DRAW.GRID)
(SETQ OLDBOX NIL)
(SETQ GRID.DRAWN NIL))
(replace (POSITION XCOORD) of PT with (MAX XMIN (MIN XMAX X)))
(replace (POSITION YCOORD) of PT with (MAX YMIN (MIN YMAX Y)))
[if (AND GRID.DRAWN FIXEDPT MOVINGPT)
then (PROG ((X1 (fetch (POSITION XCOORD) of FIXEDPT))
(Y1 (fetch (POSITION YCOORD) of FIXEDPT))
(X2 (fetch (POSITION XCOORD) of PT))
(Y2 (fetch (POSITION YCOORD) of PT)))
(SETQ OLDBOX (FLIP.ENCLOSED.BOX (IDIFFERENCE X1 XMIN)
(IDIFFERENCE Y1 YMIN)
(IDIFFERENCE X2 XMIN)
(IDIFFERENCE Y2 YMIN)
OLDBOX]
(RPLACA GETREGIONFNARG GRID.DRAWN)
(RPLACA (CDR GETREGIONFNARG)
OLDBOX)
(RETURN PT])
(CREATE.COLOR.NAME
[LAMBDA NIL (* kkm "19-Nov-84 11:51")
(DECLARE (GLOBALVARS CURRENT.INTERFACE))
(PROG (COLOR.NAMES)
(SETQ COLOR.NAMES (for ITEM in (GET.FIELDQ (FIND.FRAME CURRENT.INTERFACE (QUOTE COLORS))
ITEMS FRAME)
when (EQ (ITEM.TYPE ITEM)
(QUOTE COLOR))
collect (GET.PARAMQ ITEM NAME COLOR)))
(RETURN (MENU (create MENU
ITEMS ←(MERGEINSERT (QUOTE BLACK)
(MERGEINSERT (QUOTE WHITE)
(SORT COLOR.NAMES)
T)
T)
CENTERFLG ← T
CHANGEOFFSETFLG ← T])
(CREATE.INTEGER
[LAMBDA (PTYPE)
(RNUMBER])
(CREATE.ITEM
[LAMBDA (ITEM.TYPE) (* HaKo "16-Aug-84 14:42")
(TRILLIUM.PRINTOUT ON TRILLIUM.TRACE "Creation of a new " ITEM.TYPE)
(NEW.ITEM ITEM.TYPE])
(CREATE.LIST
[LAMBDA (ITEM.TYPE) (* PH "24-Aug-84 10:51")
(COND
[(EQUAL ITEM.TYPE (QUOTE (STRING)))
(TRILLIUM.PRINTOUT ON PROMPTWINDOW "Type in a list of strings: ")
(PROG ((RES (PROMPT.READ)))
(RETURN (OR (LISTP RES)
(LIST RES]
(T (TRILLIUM.PRINTOUT ON TRILLIUM.TRACE "Gathering a LIST of " ITEM.TYPE)
(until (CONFIRM "Done with list?") collect (CREATE.OBJECT ITEM.TYPE])
(CREATE.OBJECT
[LAMBDA (OTYPE PARAMETER.NAME ITEM) (* HaKo "17-Aug-84 14:46")
(COND
((ATOM OTYPE)
(CREATE.ITEM OTYPE))
(T (PROG (CREATE.FN)
(SETQ CREATE.FN (FUNCTION.FOR.PTYPE (CAR OTYPE)
(QUOTE CREATE)))
(RETURN (COND
(CREATE.FN (APPLY* CREATE.FN OTYPE PARAMETER.NAME ITEM))
(T (TRILLIUM.PRINTOUT ON PROMPTWINDOW
"CREATE: Enter an expression to be eval'd to get the object: ")
(EVAL (PROMPT.READ])
(CREATE.ONEOF
[LAMBDA (TYPES) (* HK "15-JUL-82 11:57")
(MENU (create MENU
TITLE ← "Choose one of"
ITEMS ← TYPES
CENTERFLG ← T
CHANGEOFFSETFLG ← T])
(CREATE.STRUCTURE
[LAMBDA (ELEMENTS) (* HaKo "25-Jul-84 16:13")
(for ELEMENT in ELEMENTS
collect (TRILLIUM.PRINTOUT ON PROMPTWINDOW (CAR ELEMENT))
(CREATE.OBJECT (CADR ELEMENT])
(FLIP.ENCLOSED.BOX
[LAMBDA (X1 Y1 X2 Y2 OLDBOX) (* HaKo "10-Aug-84 16:23")
(if (AND (NEQ X1 X2)
(NEQ Y1 Y2))
then (PROG [(LEFT (MIN X1 X2))
(BOTTOM (MIN Y1 Y2))
(RIGHT (MAX X1 X2))
(TOP (MAX Y1 Y2))
(BOX (OR OLDBOX (create REGION]
(if (OR (NULL OLDBOX)
(NEQ LEFT (fetch (REGION LEFT) of BOX))
(NEQ BOTTOM (fetch (REGION BOTTOM) of BOX))
(NEQ (IDIFFERENCE RIGHT LEFT)
(fetch (REGION WIDTH) of BOX))
(NEQ (IDIFFERENCE TOP BOTTOM)
(fetch (REGION HEIGHT) of BOX)))
then (if OLDBOX
then (FLIP.BOX OLDBOX))
(replace (REGION LEFT) of BOX with LEFT)
(replace (REGION BOTTOM) of BOX with BOTTOM)
(replace (REGION WIDTH) of BOX with (IDIFFERENCE RIGHT LEFT))
(replace (REGION HEIGHT) of BOX with (IDIFFERENCE TOP BOTTOM))
(FLIP.BOX BOX))
(RETURN BOX])
(GET.BITMAP.NAME.MENU
[LAMBDA (BITMAP.NAMES RETURN.TO.CLASS.MENU) (* edited: "20-Nov-84 11:25")
(DECLARE (GLOBALVARS BITMAP.NAME.MENU))
(PROG (COLUMNS)
(SETQ BITMAP.NAMES (SORT BITMAP.NAMES))
[COND
((AND BITMAP.NAMES (EQUAL (CAR BITMAP.NAME.MENU)
BITMAP.NAMES)))
(T (SETQ COLUMNS (MAX (IQUOTIENT (LENGTH BITMAP.NAMES)
30)
1))
(SETQ BITMAP.NAME.MENU (CONS BITMAP.NAMES (create MENU
ITEMS ←(APPEND (LIST
RETURN.TO.CLASS.MENU)
(VERTICAL.SORT
BITMAP.NAMES
COLUMNS))
CENTERFLG ← T
CHANGEOFFSETFLG ← T
MENUCOLUMNS ← COLUMNS]
(RETURN (CDR BITMAP.NAME.MENU])
(GETPOINTONGRID
[LAMBDA (PT DELTAS) (* edited: " 3-JAN-83 16:35")
(DECLARE (GLOBALVARS TRILLIUM.GRID.DX TRILLIUM.GRID.DY TRILLIUM.GRID.HALF.DX
TRILLIUM.GRID.HALF.DY TRILLIUM.GRID.X0 TRILLIUM.GRID.Y0))
(create POSITION
XCOORD ←(IDIFFERENCE (XGRIDIFY (IPLUS (fetch (POSITION XCOORD) of PT)
(CAR DELTAS)))
(CAR DELTAS))
YCOORD ←(IDIFFERENCE (YGRIDIFY (IPLUS (fetch (POSITION YCOORD) of PT)
(CDR DELTAS)))
(CDR DELTAS])
(GETREGIONONGRID
[LAMBDA (FIXEDPOINT MOVINGPOINT DELTAS) (* edited: " 3-JAN-83 16:35")
(GETPOINTONGRID (OR MOVINGPOINT FIXEDPOINT)
DELTAS])
(HITS.IN.FRAME
[LAMBDA (FRAME FROM.SUPERFRAMES.TOO ITYPE XCOORD YCOORD) (* HaKo "13-Aug-84 16:57")
(* DAHJr "19-APR-83 15:59")
(* * Note: this function makes sure to return the list of items such that the topmost item is in front.)
(DECLARE (GLOBALVARS CURRENT.INTERFACE))
(PROG (HITS)
(COND
(FROM.SUPERFRAMES.TOO (for SUPERFRAME.NAME in (GET.FIELDQ FRAME SUPERFRAMES)
do (SETQ HITS (NCONC (HITS.IN.FRAME (FIND.FRAME
CURRENT.INTERFACE
SUPERFRAME.NAME)
FROM.SUPERFRAMES.TOO ITYPE
XCOORD YCOORD)
HITS)))
y))
(for ITEM in (GET.FIELDQ FRAME ITEMS FRAME) when (AND (OR (NULL ITYPE)
(EQ ITYPE (ITEM.TYPE ITEM)))
(INSIDEP (BOUNDING.BOX ITEM)
XCOORD YCOORD))
do (SETQ HITS (CONS ITEM HITS)))
(RETURN HITS])
(MENU.ITEM.GREATER
[LAMBDA (MENU.ITEM.1 MENU.ITEM.2) (* DAHJr "10-AUG-83 15:54")
(ALPHORDER (CAR MENU.ITEM.1)
(CAR MENU.ITEM.2])
(VERTICAL.SORT
[LAMBDA (MENU.ITEMS COLUMNS) (* KKM "30-May-84 14:01")
(PROG (#ITEMS ROWS LEFTOVER POINTER COLUMN#)
(SETQ #ITEMS (LENGTH MENU.ITEMS))
(SETQ ROWS (IQUOTIENT #ITEMS COLUMNS))
(SETQ LEFTOVER (IREMAINDER #ITEMS COLUMNS))
(SETQ POINTER 1)
(RETURN
(for ITEM from 1 to #ITEMS
collect
(CAR (NTH MENU.ITEMS
(COND
((EQ ITEM 1)
1)
(T (COND
((ZEROP (SETQ POINTER
(IREMAINDER (PLUS POINTER ROWS
(COND
((EQP (ADD1 LEFTOVER)
COLUMNS)
1)
((AND (ILEQ (SETQ COLUMN#
(IREMAINDER ITEM COLUMNS)
)
(ADD1 LEFTOVER))
(IGREATERP COLUMN# 0))
1)
(T 0)))
#ITEMS)))
#ITEMS)
(T POINTER])
)
(PUTPROPS TRI-CREATE COPYRIGHT ("Xerox Corporation" 1984))
(DECLARE: DONTCOPY
(FILEMAP (NIL (967 28913 (ACQUIRE.CLASS.NAME 977 . 1792) (ACQUIRE.FRAME.NAME 1794 . 2240) (
ACQUIRE.INTERFACE.NAME 2242 . 2523) (ACQUIRE.ITEM 2525 . 3477) (ACQUIRE.ITEM.FROM 3479 . 4174) (
ACQUIRE.ITEM.TYPE 4176 . 4632) (ACQUIRE.ITEM.TYPE.SIMPLE 4634 . 5081) (ACQUIRE.MOVED.LOCATION 5083 .
6487) (ACQUIRE.MOVED.PLACEMENT 6489 . 7008) (ACQUIRE.MOVED.POSITION 7010 . 9483) (ACQUIRE.NAME 9485 .
9689) (ACQUIRE.NAMED.ITEM.FROM 9691 . 10462) (ACQUIRE.PLACEMENT 10464 . 11595) (ACQUIRE.POSITION 11597
. 15870) (ACQUIRE.REGION 15872 . 19683) (ACQUIRE.REGION.GETREGIONFN 19685 . 21971) (CREATE.COLOR.NAME
21973 . 22616) (CREATE.INTEGER 22618 . 22670) (CREATE.ITEM 22672 . 22879) (CREATE.LIST 22881 . 23346)
(CREATE.OBJECT 23348 . 23848) (CREATE.ONEOF 23850 . 24074) (CREATE.STRUCTURE 24076 . 24338) (
FLIP.ENCLOSED.BOX 24340 . 25368) (GET.BITMAP.NAME.MENU 25370 . 26130) (GETPOINTONGRID 26132 . 26669) (
GETREGIONONGRID 26671 . 26853) (HITS.IN.FRAME 26855 . 27831) (MENU.ITEM.GREATER 27833 . 28008) (
VERTICAL.SORT 28010 . 28911)))))
STOP