(FILECREATED "19-Nov-84 16:51:11" {AZTEC}<TRILLIUM>BIRTHDAY84>RERELEASE>BASIC-PTYPES.;3 24816
changes to: (FNS LIST/WALK STRUCTURE/WALK BITMAP.NAME/CREATE)
previous date: "17-Aug-84 21:15:49" {AZTEC}<TRILLIUM>BIRTHDAY84>RERELEASE>BASIC-PTYPES.;2)
(* Copyright (c) 1984 by Xerox Corporation)
(PRETTYCOMPRINT BASIC-PTYPESCOMS)
(RPAQQ BASIC-PTYPESCOMS ((PTYPES BITMAP BITMAP.NAME CELL COLOR.NAME COLOR.NUMBER COMPUTED.VALUE
CONSTANT COPY FONT FORM FRAME FRAME.CLASSES GRIDREGION INTEGER ITEM
ITYPE.CLASSES LIST LOCATION LOCATION2 OFFSET.VECTOR ONEOF POSITION
POSITION2 QUOTE REGION SHADE STRING STRUCTURE)
(BITMAPS TRILLIUM.X.BITMAP)))
(READ.PTYPE BITMAP 1)
(\TYPE PTYPE NAME BITMAP COMMENT "A BITBLT texture" OTHER (FNS ((CREATE BITMAP/CREATE) (EDIT
BITMAP/EDIT))))
(DEFINEQ
(BITMAP/CREATE
(LAMBDA (TYPE) (* HaKo " 6-Aug-84 13:00") (* DAHJr "13-JUN-83 19:04") (DECLARE (SPECVARS NEW.BITMAP))
(PROG (SCREEN.REGION NEW.BITMAP WIDTH HEIGHT) (TRILLIUM.PRINTOUT
"Indicate size and initial bitmap by designating a region of the screen") (SETQ SCREEN.REGION (
GETREGION)) (SETQ WIDTH (fetch (REGION WIDTH) of SCREEN.REGION)) (SETQ HEIGHT (fetch (REGION HEIGHT)
of SCREEN.REGION)) (SETQ NEW.BITMAP (BITMAPCREATE WIDTH HEIGHT)) (BITBLT (SCREENBITMAP) (fetch (REGION
LEFT) of SCREEN.REGION) (fetch (REGION BOTTOM) of SCREEN.REGION) NEW.BITMAP 0 0 WIDTH HEIGHT (QUOTE
INPUT) (QUOTE REPLACE)) (NLSETQ (EDITBM NEW.BITMAP)) (RETURN NEW.BITMAP))))
(BITMAP/EDIT
(LAMBDA (TYPE OBJECT) (EDIT.BITMAP OBJECT)))
)
(READ.PTYPE BITMAP.NAME 1)
(\TYPE PTYPE NAME BITMAP.NAME COMMENT "A Bitmap name" OTHER (FNS ((CREATE BITMAP.NAME/CREATE))))
(DEFINEQ
(BITMAP.NAME/CREATE
[LAMBDA (TYPE) (* kkm "19-Nov-84 12:38")
(DECLARE (GLOBALVARS CURRENT.FRAME CURRENT.FRAME.CLASSES CURRENT.INTERFACE))
(PROG [BITMAPNAMEMENU FRAMENAMEMENU BITMAPNAME FRAMELIST (RETURNTOCLASSMENU
(CONSTANT (MENUNAME.FROM.CLASSNAME (QUOTE RETURN.TO.FRAME.LIST]
(* USING STRUCTURED MENUS (PROG (NAMES) (SETQ NAMES (for ITEM in (GET.FIELDQ (FIND.FRAME CURRENT.DIALOG
(QUOTE BITMAPS)) ITEMS FRAME) when (EQ (ITEM.TYPE ITEM) (QUOTE BITMAP)) collect (GET.FIELDQ ITEM NAME)))
(SETQ NAMES (SORT NAMES)) (COND ((EQUAL (CAR BITMAP.NAME.MENU) NAMES)) (T (SETQ BITMAP.NAME.MENU
(CONS NAMES (STRUCTURED.MENU.CREATE NAMES 20 NIL NIL NIL T NIL NIL NIL NIL T))))) (RETURN
(STRUCTURED.MENU.INVOKE (CDR BITMAP.NAME.MENU)))))
[SETQ FRAMELIST (OR (LISTGET CURRENT.FRAME.CLASSES (QUOTE BITMAP.FRAMES))
(LIST (QUOTE BITMAPS]
(SETQ BITMAPNAMEMENU (SETQ FRAMENAMEMENU (create MENU
TITLE ← "Choose Bitmap Frame: "
ITEMS ←[UNION (LIST (
MENUNAME.FROM.CLASSNAME (GET.FIELDQ CURRENT.FRAME NAME FRAME)))
(SORT (for FRAME
in FRAMELIST
collect
(
MENUNAME.FROM.CLASSNAME FRAME]
CENTERFLG ← T
CHANGEOFFSETFLG ← T)))
[while (MENUCLASSNAMEP (SETQ BITMAPNAME (MENU BITMAPNAMEMENU)))
do (COND
((EQ BITMAPNAME RETURNTOCLASSMENU)
(SETQ BITMAPNAMEMENU FRAMENAMEMENU))
(T (SETQ BITMAPNAMEMENU (GET.BITMAP.NAME.MENU (for ITEM
in (GET.FIELDQ
(FIND.FRAME CURRENT.INTERFACE
(
CLASSNAME.FROM.MENUNAME BITMAPNAME))
ITEMS FRAME)
when (EQ (ITEM.TYPE ITEM)
(QUOTE BITMAP))
collect (GET.PARAMQ ITEM NAME))
RETURNTOCLASSMENU]
(RETURN (OR BITMAPNAME (QUOTE EXAMPLE.BITMAP])
)
(READ.PTYPE CELL 1)
(\TYPE PTYPE NAME CELL COMMENT "A cell name" OTHER (FNS ((CREATE CELL/CREATE))))
(DEFINEQ
(CELL/CREATE
(LAMBDA (TYPE) (* DAHJr "13-JUN-83 19:11") (DECLARE (GLOBALVARS CURRENT.MACHINE.STATE)) (PROG (
COMMAND.MENU COMMAND) (SETQ COMMAND.MENU (create MENU TITLE ← "Cells" ITEMS ← (NCONC1 (for ELEMENT on
CURRENT.MACHINE.STATE by (CDDR ELEMENT) unless (EQ (CAR ELEMENT) (QUOTE \TYPE)) collect (CAR ELEMENT))
(QUOTE NEW.CELL)))) (SETQ COMMAND (MENU COMMAND.MENU)) (RETURN (SELECTQ COMMAND (NIL NIL) (NEW.CELL (
TRILLIUM.PRINTOUT "New cell name: ") (PROMPT.READ)) COMMAND)))))
)
(READ.PTYPE COLOR.NAME 1)
(\TYPE PTYPE NAME COLOR.NAME COMMENT "A color name" OTHER (FNS ((CREATE COLOR.NAME/CREATE))))
(DEFINEQ
(COLOR.NAME/CREATE
(LAMBDA (PTYPE) (* HaKo "14-Aug-84 16:35") (CREATE.COLOR.NAME)))
)
(READ.PTYPE COLOR.NUMBER 1)
(\TYPE PTYPE NAME COLOR.NUMBER COMMENT "A color number" OTHER (FNS ((CREATE COLOR.NUMBER/CREATE))))
(DEFINEQ
(COLOR.NUMBER/CREATE
(LAMBDA NIL (* DAHJr " 8-DEC-83 18:05") (MENU (create MENU TITLE ← "Choose one of" ITEMS ← (QUOTE (0 1
2 3 4 5 6 7)) CENTERFLG ← T CHANGEOFFSETFLG ← T))))
)
(READ.PTYPE COMPUTED.VALUE 1)
(\TYPE PTYPE NAME COMPUTED.VALUE COMMENT "A value computed by a form" OTHER (FNS ((CREATE
COMPUTED.VALUE/CREATE))))
(DEFINEQ
(COMPUTED.VALUE/CREATE
(LAMBDA (TYPE) (* HaKo " 6-Aug-84 13:06") (TRILLIUM.EVAL (CADR TYPE) (CONCAT
"Creating a new computed value using form " (CADR TYPE)))))
)
(READ.PTYPE CONSTANT 1)
(\TYPE PTYPE NAME CONSTANT COMMENT "A constant" OTHER (FNS ((CREATE CONSTANT/CREATE))))
(DEFINEQ
(CONSTANT/CREATE
(LAMBDA NIL (* DAHJr "19-JAN-83 16:58") (TRILLIUM.PRINTOUT "Enter a constant (word or number): ") (
PROMPT.READ)))
)
(READ.PTYPE COPY 1)
(\TYPE PTYPE NAME COPY COMMENT "A quoted thing" OTHER (FNS ((CREATE COPY/CREATE))))
(DEFINEQ
(COPY/CREATE
(LAMBDA (PTYPE) (* DAHJr "13-JUN-83 19:15") (COPYALL (CADR PTYPE))))
)
(READ.PTYPE FONT 1)
(\TYPE PTYPE NAME FONT COMMENT "A font descriptor" OTHER (FNS ((CREATE FONT/CREATE))))
(DEFINEQ
(FONT/CREATE
(LAMBDA NIL (* HaKo " 3-AUG-83 09:20") (PROG (FONT FAMILY SIZE WEIGHT SLOPE EXPANSION LOADED.FONTS
FAMILIES) (SETQ LOADED.FONTS (SORT (FONTS.IN.CORE) (FUNCTION (LAMBDA (X Y) (COND ((EQ (CAR X) (CAR Y))
(NOT (IGREATERP (CADR X) (CADR Y)))) (T (ALPHORDER (CAR X) (CAR Y)))))))) (SETQ FONT (MENU (create
MENU TITLE ← "Font:" ITEMS ← (NCONC (for FONT in LOADED.FONTS collect (LIST FONT (KWOTE FONT))) (LIST
(QUOTE (" " NIL)) (QUOTE NEW.FONT)))))) (OR (EQ FONT (QUOTE NEW.FONT)) (RETURN FONT)) (SETQ FAMILIES (
for FONT in LOADED.FONTS collect (CAR FONT))) (SETQ FAMILIES (SORT (INTERSECTION FAMILIES FAMILIES)))
(OR (SETQ FAMILY (MENU (create MENU TITLE ← "Font family:" ITEMS ← (NCONC FAMILIES (LIST (QUOTE (" "
NIL)) (QUOTE NEW.FAMILY))) CENTERFLG ← T))) (RETURN)) (COND ((EQ FAMILY (QUOTE NEW.FAMILY)) (OR (SETQ
FAMILY (ACQUIRE.NAME "Type new font family")) (RETURN)))) (SETQ SIZE (RNUMBER "Font size:")) (OR (SETQ
WEIGHT (MENU (create MENU TITLE ← "Font weight:" ITEMS ← (QUOTE (LIGHT MEDIUM BOLD)) CENTERFLG ← T)))
(RETURN)) (OR (SETQ SLOPE (MENU (create MENU TITLE ← "Font slope:" ITEMS ← (QUOTE (REGULAR ITALIC))
CENTERFLG ← T))) (RETURN)) (OR (SETQ EXPANSION (MENU (create MENU TITLE ← "Font expansion:" ITEMS ← (
QUOTE (REGULAR COMPRESSED EXPANDED)) CENTERFLG ← T))) (RETURN)) (RETURN (LIST FAMILY SIZE (LIST WEIGHT
SLOPE EXPANSION))))))
)
(READ.PTYPE FORM 1)
(\TYPE PTYPE NAME FORM COMMENT "A Lisp form" OTHER (FNS ((CREATE FORM/CREATE) (EDIT FORM/EDIT))))
(DEFINEQ
(FORM/CREATE
(LAMBDA (TYPE) (* HaKo "17-Aug-84 10:58") (EDIT.FORM (QUOTE (Edit this form into what you want)))))
(FORM/EDIT
(LAMBDA (TYPE OBJECT) (* HaKo "17-Aug-84 10:59") (EDIT.FORM OBJECT)))
)
(READ.PTYPE FRAME 1)
(\TYPE PTYPE NAME FRAME COMMENT "A frame" OTHER (FNS ((CREATE FRAME/CREATE))))
(DEFINEQ
(FRAME/CREATE
(LAMBDA NIL (* DAHJr "19-JAN-83 22:53") (DECLARE (GLOBALVARS CURRENT.INTERFACE)) (ACQUIRE.FRAME.NAME
CURRENT.INTERFACE)))
)
(READ.PTYPE FRAME.CLASSES 1)
(\TYPE PTYPE NAME FRAME.CLASSES COMMENT "A frame class" OTHER (FNS ((CREATE FRAME.CLASSES/CREATE)
(EDIT FRAME.CLASSES/EDIT))))
(DEFINEQ
(FRAME.CLASSES/CREATE
(LAMBDA NIL (* HK "27-JUL-82 16:52") (EDIT.CLASS NIL (QUOTE FRAMES))))
(FRAME.CLASSES/EDIT
(LAMBDA (TYPE OBJECT) (* DAHJr "13-JUN-83 19:23") (EDIT.CLASS OBJECT (QUOTE FRAMES))))
)
(READ.PTYPE GRIDREGION 1)
(\TYPE PTYPE NAME GRIDREGION COMMENT "A region in touch panel coordinates" OTHER (FNS ((CREATE
CREATE.GRIDREGION) (LTRANSLATE TRANSLATE.GRIDREGION))))
(DEFINEQ
(CREATE.GRIDREGION
(LAMBDA NIL (* DAHJr "19-JAN-83 14:05") (DECLARE (GLOBALVARS CURRENT.INTERFACE.WINDOW TRILLIUM.GRID.DX
TRILLIUM.GRID.DY TRILLIUM.GRID.X0 TRILLIUM.GRID.Y0)) (PROG ((WINDOW.BORDER (WINDOWPROP
CURRENT.INTERFACE.WINDOW (QUOTE BORDER))) (WINDOW.OUTLINE (WINDOWPROP CURRENT.INTERFACE.WINDOW (QUOTE
REGION))) (WINDOW.CLIPPING.REGION (DSPCLIPPINGREGION NIL (WINDOWPROP CURRENT.INTERFACE.WINDOW (QUOTE
DSP)))) NEW.REGION TRILLIUM.DELTAX TRILLIUM.DELTAY) (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
GETREGIONONGRID) (CONS TRILLIUM.DELTAX TRILLIUM.DELTAY))) (RETURN (create GRIDREGION LEFT ← (XGRID (
IPLUS (fetch (REGION LEFT) of NEW.REGION) TRILLIUM.DELTAX)) BOTTOM ← (YGRID (IPLUS (fetch (REGION
BOTTOM) of NEW.REGION) TRILLIUM.DELTAY)) WIDTH ← (MAX 1 (XGDIST (fetch (REGION WIDTH) of NEW.REGION)))
HEIGHT ← (MAX 1 (YGDIST (fetch (REGION HEIGHT) of NEW.REGION))))))))
(TRANSLATE.GRIDREGION
(LAMBDA (PLACEMENT DX DY) (* DAHJr "13-JUN-83 18:42") (COND (DX (create GRIDREGION LEFT ← (IPLUS DX (
fetch (GRIDREGION LEFT) of PLACEMENT)) BOTTOM ← (IPLUS DY (fetch (GRIDREGION BOTTOM) of PLACEMENT))
WIDTH ← (fetch (GRIDREGION WIDTH) of PLACEMENT) HEIGHT ← (fetch (GRIDREGION HEIGHT) of PLACEMENT))) (T
(create LOCATION X ← (fetch (GRIDREGION LEFT) of PLACEMENT) Y ← (fetch (GRIDREGION BOTTOM) of
PLACEMENT))))))
)
(READ.PTYPE INTEGER 1)
(\TYPE PTYPE NAME INTEGER COMMENT "An integer" OTHER (FNS ((CREATE INTEGER/CREATE))))
(DEFINEQ
(INTEGER/CREATE
(LAMBDA (PTYPE) (* HaKo "14-Aug-84 16:37") (CREATE.INTEGER)))
)
(READ.PTYPE ITEM 1)
(\TYPE PTYPE NAME ITEM COMMENT "An item of any sort" OTHER (FNS ((CREATE ITEM/CREATE) (EDIT
ITEM/EDIT) (WALK ITEM/WALK))))
(DEFINEQ
(ITEM/CREATE
(LAMBDA (TYPE) (* HaKo "14-Aug-84 16:41") (* DAHJr "13-JUN-83 19:17") (CREATE.ITEM (if (LISTP (CADR
TYPE)) then (CAADR TYPE) else (ACQUIRE.ITEM.TYPE)))))
(ITEM/EDIT
(LAMBDA (TYPE OBJECT) (EDIT.WINDOW.CREATE OBJECT)))
(ITEM/WALK
(LAMBDA (ITEM PTYPE CONTEXT ACTIONFN ACTIONFNARG) (* HaKo "15-Aug-84 13:47") (WALK.ITEM ITEM CONTEXT
ACTIONFN ACTIONFNARG)))
)
(READ.PTYPE ITYPE.CLASSES 1)
(\TYPE PTYPE NAME ITYPE.CLASSES COMMENT "An itemtype class" OTHER (FNS ((CREATE
ITYPE.CLASSES/CREATE) (EDIT ITYPE.CLASSES/EDIT))))
(DEFINEQ
(ITYPE.CLASSES/CREATE
(LAMBDA NIL (* HK "27-JUL-82 16:51") (EDIT.CLASS NIL (QUOTE ITEM.TYPES))))
(ITYPE.CLASSES/EDIT
(LAMBDA (TYPE OBJECT) (* HaKo "17-Aug-84 11:04") (EDIT.CLASS OBJECT (QUOTE ITEM.TYPES))))
)
(READ.PTYPE LIST 1)
(\TYPE PTYPE NAME LIST COMMENT "A list" OTHER (FNS ((CREATE LIST/CREATE) (EDIT LIST/EDIT) (WALK
LIST/WALK))))
(DEFINEQ
(LIST/CREATE
(LAMBDA (PTYPE) (* DAHJr "23-JUN-83 09:16") (CREATE.LIST (CADR PTYPE))))
(LIST/EDIT
(LAMBDA (TYPE OBJECT) (EDIT.LIST OBJECT (CADR TYPE))))
(LIST/WALK
[LAMBDA (LIST PTYPE CONTEXT ACTIONFN ACTIONFNARG) (* HaKo "15-Aug-84 14:02")
(for OBJECT in LIST bind (RESULT (SUB.TYPE ←(CADR PTYPE))
(NEWCONTEXT ←(LIST LIST CONTEXT)))
when (SETQ RESULT (WALK.OBJECT OBJECT SUB.TYPE NEWCONTEXT ACTIONFN ACTIONFNARG))
do (RETURN RESULT])
)
(READ.PTYPE LOCATION 1)
(\TYPE PTYPE NAME LOCATION COMMENT "A position in screen coordinates" OTHER (FNS ((CREATE
LOCATION/CREATE) (LTRANSLATE LOCATION/LTRANSLATE))))
(DEFINEQ
(LOCATION/CREATE
(LAMBDA (TYPE) (* HaKo "13-Aug-84 09:14") (* DAHJr "13-JUN-83 18:06") (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 (LASTX LASTY MARKX MARKY PREVIOUSX PREVIOUSY) (
SETQ LASTX (XGRIDNEAR (LASTMOUSEX CURRENT.DSP))) (SETQ LASTY (YGRIDNEAR (LASTMOUSEY CURRENT.DSP))) (
SETQ MARKX (XCOORD LASTX)) (SETQ MARKY (YCOORD LASTY)) (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) (SETQ
MARKX (XCOORD LASTX)) (SETQ MARKY (YCOORD LASTY)) (FLIP.SPOT MARKX MARKY) (SETQ PREVIOUSX LASTX) (SETQ
PREVIOUSY LASTY)))) (FLIP.SPOT MARKX MARKY) (WAITNOBUG) (RETURN (CONS LASTX LASTY)))))
(LOCATION/LTRANSLATE
(LAMBDA (PLACEMENT DX DY) (* HaKo "17-Aug-84 11:06") (* DAHJr "13-JUN-83 18:12") (OBS
"No more grid stuff!") (COND (DX (create LOCATION X ← (IPLUS DX (fetch (LOCATION X) of PLACEMENT)) Y ←
(IPLUS DY (fetch (LOCATION Y) of PLACEMENT)))) (T (create LOCATION X ← (fetch (LOCATION X) of
PLACEMENT) Y ← (fetch (LOCATION Y) of PLACEMENT))))))
)
(READ.PTYPE LOCATION2 1)
(\TYPE PTYPE NAME LOCATION2 COMMENT "A 2-point position in touchpanel coordinates" OTHER (FNS ((
CREATE LOCATION2/CREATE) (LTRANSLATE LOCATION2/LTRANSLATE) (NIL CREATE.LOCATION.WITH.BANDING))))
(DEFINEQ
(LOCATION2/CREATE
(LAMBDA (TYPE) (* KKM " 9-JAN-84 11:23") (PROG (L1 L2) (TRILLIUM.PRINTOUT
"Point out first grid location (of two)") (SETQ L1 (CREATE.LOCATION)) (TRILLIUM.PRINTOUT
"Point out second grid location (of two)") (SETQ L2 (CREATE.LOCATION.WITH.BANDING L1)) (RETURN (
NEW.LOCATION2 L1 L2)))))
(LOCATION2/LTRANSLATE
(LAMBDA (PLACEMENT DX DY) (* DAHJr "13-JUN-83 18:48") (COND (DX (create LOCATION2 X1 ← (IPLUS DX (
fetch (LOCATION2 X1) of PLACEMENT)) Y1 ← (IPLUS DY (fetch (LOCATION2 Y1) of PLACEMENT)) X2 ← (IPLUS DX
(fetch (LOCATION2 X2) of PLACEMENT)) Y2 ← (IPLUS DY (fetch (LOCATION2 Y2) of PLACEMENT)))) (T (create
LOCATION X ← (fetch (LOCATION2 X1) of PLACEMENT) Y ← (fetch (LOCATION2 Y1) of PLACEMENT))))))
(CREATE.LOCATION.WITH.BANDING
(LAMBDA (FIRST.POINT) (* edited: "21-JAN-83 16:19") (DECLARE (GLOBALVARS CURRENT.DSP TRILLIUM.GRID.DX
TRILLIUM.GRID.DY TRILLIUM.GRID.HALF.DX TRILLIUM.GRID.HALF.DY TRILLIUM.GRID.X0 TRILLIUM.GRID.Y0)) (PROG
(FIRSTX FIRSTY LASTX LASTY MARKX MARKY PREVIOUSX PREVIOUSY) (SETQ LASTX (XGRIDNEAR (LASTMOUSEX
CURRENT.DSP))) (SETQ LASTY (YGRIDNEAR (LASTMOUSEY CURRENT.DSP))) (SETQ FIRSTX (XCOORD (CAR FIRST.POINT
))) (SETQ FIRSTY (YCOORD (CDR FIRST.POINT))) (SETQ MARKX (XCOORD LASTX)) (SETQ MARKY (YCOORD LASTY)) (
DRAWLINE FIRSTX FIRSTY MARKX MARKY 1 (QUOTE INVERT) CURRENT.DSP) (while (ZEROP (MOUSEBUTTONS)) do (
SETQ LASTX (XGRIDNEAR (LASTMOUSEX CURRENT.DSP))) (SETQ LASTY (YGRIDNEAR (LASTMOUSEY CURRENT.DSP))) (
COND ((OR (NEQ LASTX PREVIOUSX) (NEQ LASTY PREVIOUSY)) (DRAWLINE FIRSTX FIRSTY MARKX MARKY 1 (QUOTE
INVERT) CURRENT.DSP) (SETQ MARKX (XCOORD LASTX)) (SETQ MARKY (YCOORD LASTY)) (DRAWLINE FIRSTX FIRSTY
MARKX MARKY 1 (QUOTE INVERT) CURRENT.DSP) (SETQ PREVIOUSX LASTX) (SETQ PREVIOUSY LASTY)))) (DRAWLINE
FIRSTX FIRSTY MARKX MARKY 1 (QUOTE INVERT) CURRENT.DSP) (WAITNOBUG) (RETURN (CONS LASTX LASTY)))))
)
(READ.PTYPE OFFSET.VECTOR 1)
(\TYPE PTYPE NAME OFFSET.VECTOR COMMENT "A position in screen coordinates" OTHER (FNS ((CREATE
OFFSET.VECTOR/CREATE) (NIL FLIP.X))))
(DEFINEQ
(OFFSET.VECTOR/CREATE
(LAMBDA (TYPE PNAME ITEM) (* HaKo "17-Aug-84 15:26") (PROG (REF.PNAME P1 P2) (if (SETQ REF.PNAME (CAR
(LISTP (CADR (LISTP TYPE))))) then (SETQ P1 (GET.PARAM ITEM REF.PNAME)) else (TRILLIUM.PRINTOUT
"Point out the reference point for the offset") (SETQ P1 (ACQUIRE.POSITION))) (TRILLIUM.PRINTOUT
"Point out the offset") (SETQ P2 (ACQUIRE.POSITION P1 T)) (RETURN (NEW.POSITION (IDIFFERENCE (fetch (
POSITION XCOORD) of P2) (fetch (POSITION XCOORD) of P1)) (IDIFFERENCE (fetch (POSITION YCOORD) of P2)
(fetch (POSITION YCOORD) of P1)))))))
(FLIP.X
(LAMBDA (XCOORD YCOORD) (* KKM "12-Jun-84 08:53") (DECLARE (GLOBALVARS CURRENT.DSP TRILLIUM.X.BITMAP))
(PROG (WIDTH HEIGHT) (SETQ WIDTH (fetch (BITMAP BITMAPWIDTH) of TRILLIUM.X.BITMAP)) (SETQ HEIGHT (
fetch (BITMAP BITMAPHEIGHT) of TRILLIUM.X.BITMAP)) (BITBLT TRILLIUM.X.BITMAP 0 0 CURRENT.DSP (
IDIFFERENCE XCOORD (IQUOTIENT WIDTH 2)) (IDIFFERENCE YCOORD (IQUOTIENT HEIGHT 2)) WIDTH HEIGHT (QUOTE
INPUT) (QUOTE INVERT)))))
)
(READ.PTYPE ONEOF 1)
(\TYPE PTYPE NAME ONEOF COMMENT "A choice" OTHER (FNS ((CREATE ONEOF/CREATE))))
(DEFINEQ
(ONEOF/CREATE
(LAMBDA (TYPE) (CREATE.ONEOF (CADR TYPE))))
)
(READ.PTYPE POSITION 1)
(\TYPE PTYPE NAME POSITION COMMENT "A position in screen coordinates" OTHER (FNS ((CREATE
POSITION/CREATE) (TRANSLATE POSITION/TRANSLATE))))
(DEFINEQ
(POSITION/CREATE
(LAMBDA (TYPE) (* HaKo "13-Aug-84 09:26") (* * old way: (* DAHJr "13-JUN-83 17:59") (PROG (LASTX LASTY
MARKX MARKY PREVIOUSX PREVIOUSY) (SETQ LASTX (LASTMOUSEX CURRENT.DSP)) (SETQ LASTY (LASTMOUSEY
CURRENT.DSP)) (SETQ MARKX LASTX) (SETQ MARKY LASTY) (FLIP.SPOT MARKX MARKY) (while (ZEROP (
MOUSEBUTTONS)) do (SETQ LASTX (LASTMOUSEX CURRENT.DSP)) (SETQ LASTY (LASTMOUSEY CURRENT.DSP)) (COND ((
KEYDOWNP (QUOTE LSHIFT)) (SETQ LASTX (XGRIDIFY LASTX)) (SETQ LASTY (YGRIDIFY LASTY)))) (COND ((OR (NEQ
LASTX PREVIOUSX) (NEQ LASTY PREVIOUSY)) (FLIP.SPOT MARKX MARKY) (SETQ MARKX LASTX) (SETQ MARKY LASTY)
(FLIP.SPOT MARKX MARKY) (SETQ PREVIOUSX LASTX) (SETQ PREVIOUSY LASTY)))) (FLIP.SPOT MARKX MARKY) (
WAITNOBUG) (RETURN (CONS LASTX LASTY)))) (ACQUIRE.POSITION)))
(POSITION/TRANSLATE
(LAMBDA (POSITION DX DY) (* DAHJr " 6-OCT-83 17:39") (COND (DX (PROG (RDX RDY) (COND (DY (SETQ RDX DX)
(SETQ RDY DY)) (T (SETQ RDX (fetch (POSITION XCOORD) of DX)) (SETQ RDY (fetch (POSITION YCOORD) of DX
)))) (RETURN (create POSITION XCOORD ← (IPLUS RDX (fetch (POSITION XCOORD) of POSITION)) YCOORD ← (
IPLUS RDY (fetch (POSITION YCOORD) of POSITION)))))) (T POSITION))))
)
(READ.PTYPE POSITION2 1)
(\TYPE PTYPE NAME POSITION2 COMMENT "A 2-point position in screen coordinates" OTHER (FNS ((CREATE
POSITION2/CREATE CREATE.POSITION2) (TRANSLATE POSITION2/TRANSLATE))))
(DEFINEQ
(POSITION2/CREATE
(LAMBDA (TYPE) (* HaKo "17-Aug-84 11:31") (* DAHJr "13-JUN-83 18:44") (PROG (P1 P2) (TRILLIUM.PRINTOUT
"Point out first position (of two)") (SETQ P1 (ACQUIRE.POSITION)) (TRILLIUM.PRINTOUT
"Point out second position (of two)") (SETQ P2 (ACQUIRE.POSITION P1 T)) (RETURN (NEW.POSITION2 P1 P2))
)))
(POSITION2/TRANSLATE
(LAMBDA (PLACEMENT DX DY) (* DAHJr " 6-OCT-83 18:40") (COND (DX (PROG (RDX RDY) (COND (DY (SETQ RDX DX
) (SETQ RDY DY)) (T (SETQ RDX (fetch (POSITION XCOORD) of DX)) (SETQ RDY (fetch (POSITION YCOORD) of
DX)))) (RETURN (create POSITION2 XCOORD1 ← (IPLUS RDX (fetch (POSITION2 XCOORD1) of PLACEMENT))
YCOORD1 ← (IPLUS RDY (fetch (POSITION2 YCOORD1) of PLACEMENT)) XCOORD2 ← (IPLUS RDX (fetch (POSITION2
XCOORD2) of PLACEMENT)) YCOORD2 ← (IPLUS RDY (fetch (POSITION2 YCOORD2) of PLACEMENT)))))) (T (create
POSITION XCOORD ← (fetch (POSITION2 XCOORD1) of PLACEMENT) YCOORD ← (fetch (POSITION2 YCOORD1) of
PLACEMENT))))))
)
(READ.PTYPE QUOTE 1)
(\TYPE PTYPE NAME QUOTE COMMENT "A quoted thing" OTHER (FNS ((CREATE QUOTE/CREATE))))
(DEFINEQ
(QUOTE/CREATE
(LAMBDA (PTYPE) (* DAHJr "13-JUN-83 18:52") (CADR PTYPE)))
)
(READ.PTYPE REGION 1)
(\TYPE PTYPE NAME REGION COMMENT "A region in screen coordinates" OTHER (FNS ((CREATE REGION/CREATE
) (TRANSLATE REGION/TRANSLATE) (NIL REGION/LEFT) (NIL REGION/RIGHT) (NIL REGION/BOTTOM) (NIL
REGION/TOP) (NIL REGION/WIDTH) (NIL REGION/HEIGHT) (NIL REGION/CENTER) (NIL REGION/NORTH) (NIL
REGION/NORTHEAST) (NIL REGION/EAST) (NIL REGION/SOUTHEAST) (NIL REGION/SOUTH) (NIL
REGION/SOUTHWEST) (NIL REGION/WEST) (NIL REGION/NORTHWEST))))
(DEFINEQ
(REGION/CREATE
(LAMBDA (TYPE) (* DAHJr "23-JUN-83 17:17") (ACQUIRE.REGION)))
(REGION/TRANSLATE
(LAMBDA (PLACEMENT DX DY) (* DAHJr " 6-OCT-83 18:11") (COND (DX (PROG (RDX RDY) (COND (DY (SETQ RDX DX
) (SETQ RDY DY)) (T (SETQ RDX (fetch (POSITION XCOORD) of DX)) (SETQ RDY (fetch (POSITION YCOORD) of
DX)))) (RETURN (create REGION LEFT ← (IPLUS RDX (fetch (REGION LEFT) of PLACEMENT)) BOTTOM ← (IPLUS
RDY (fetch (REGION BOTTOM) of PLACEMENT)) WIDTH ← (fetch (REGION WIDTH) of PLACEMENT) HEIGHT ← (fetch
(REGION HEIGHT) of PLACEMENT))))) (T (create POSITION XCOORD ← (fetch (REGION LEFT) of PLACEMENT)
YCOORD ← (fetch (REGION BOTTOM) of PLACEMENT))))))
(REGION/LEFT
(LAMBDA (REGION) (fetch (REGION LEFT) of REGION)))
(REGION/RIGHT
(LAMBDA (REGION) (* DAHJr " 4-JUN-83 22:10") (IPLUS (fetch (REGION LEFT) of REGION) (fetch (REGION
WIDTH) of REGION) -1)))
(REGION/BOTTOM
(LAMBDA (REGION) (* DAHJr " 4-JUN-83 22:11") (fetch (REGION BOTTOM) of REGION)))
(REGION/TOP
(LAMBDA (REGION) (* DAHJr " 4-JUN-83 22:12") (IPLUS (fetch (REGION BOTTOM) of REGION) (fetch (REGION
HEIGHT) of REGION) -1)))
(REGION/WIDTH
(LAMBDA (REGION) (* DAHJr " 4-JUN-83 22:12") (fetch (REGION WIDTH) of REGION)))
(REGION/HEIGHT
(LAMBDA (REGION) (* DAHJr " 4-JUN-83 22:13") (fetch (REGION HEIGHT) of REGION)))
(REGION/CENTER
(LAMBDA (REGION) (* DAHJr "15-JAN-83 16:37") (create POSITION XCOORD ← (IPLUS (fetch (REGION LEFT) of
REGION) (IQUOTIENT (fetch (REGION WIDTH) of REGION) 2)) YCOORD ← (IPLUS (fetch (REGION BOTTOM) of
REGION) (IQUOTIENT (fetch (REGION HEIGHT) of REGION) 2)))))
(REGION/NORTH
(LAMBDA (REGION) (* DAHJr "12-JUN-83 22:55") (create POSITION XCOORD ← (IPLUS (fetch (REGION LEFT) of
REGION) (IQUOTIENT (fetch (REGION WIDTH) of REGION) 2)) YCOORD ← (IPLUS (fetch (REGION BOTTOM) of
REGION) (fetch (REGION HEIGHT) of REGION) -1))))
(REGION/NORTHEAST
(LAMBDA (REGION) (* DAHJr "12-JUN-83 22:55") (create POSITION XCOORD ← (IPLUS (fetch (REGION LEFT) of
REGION) (fetch (REGION WIDTH) of REGION) -1) YCOORD ← (IPLUS (fetch (REGION BOTTOM) of REGION) (fetch
(REGION HEIGHT) of REGION) -1))))
(REGION/EAST
(LAMBDA (REGION) (* DAHJr "12-JUN-83 22:56") (create POSITION XCOORD ← (IPLUS (fetch (REGION LEFT) of
REGION) (fetch (REGION WIDTH) of REGION) -1) YCOORD ← (IPLUS (fetch (REGION BOTTOM) of REGION) (
IQUOTIENT (fetch (REGION HEIGHT) of REGION) 2)))))
(REGION/SOUTHEAST
(LAMBDA (REGION) (* DAHJr "12-JUN-83 22:56") (create POSITION XCOORD ← (IPLUS (fetch (REGION LEFT) of
REGION) (fetch (REGION WIDTH) of REGION) -1) YCOORD ← (fetch (REGION BOTTOM) of REGION))))
(REGION/SOUTH
(LAMBDA (REGION) (* DAHJr "12-JUN-83 22:57") (create POSITION XCOORD ← (IPLUS (fetch (REGION LEFT) of
REGION) (IQUOTIENT (fetch (REGION WIDTH) of REGION) 2)) YCOORD ← (fetch (REGION BOTTOM) of REGION))))
(REGION/SOUTHWEST
(LAMBDA (REGION) (* DAHJr "12-JUN-83 22:57") (create POSITION XCOORD ← (fetch (REGION LEFT) of REGION)
YCOORD ← (fetch (REGION BOTTOM) of REGION))))
(REGION/WEST
(LAMBDA (REGION) (* DAHJr "12-JUN-83 22:58") (create POSITION XCOORD ← (fetch (REGION LEFT) of REGION)
YCOORD ← (IPLUS (fetch (REGION BOTTOM) of REGION) (IQUOTIENT (fetch (REGION HEIGHT) of REGION) 2)))))
(REGION/NORTHWEST
(LAMBDA (REGION) (* DAHJr "12-JUN-83 22:58") (create POSITION XCOORD ← (fetch (REGION LEFT) of REGION)
YCOORD ← (IPLUS (fetch (REGION BOTTOM) of REGION) (fetch (REGION HEIGHT) of REGION) -1))))
)
(READ.PTYPE SHADE 1)
(\TYPE PTYPE NAME SHADE COMMENT "A BITBLT texture" OTHER (FNS ((CREATE SHADE/CREATE) (EDIT
SHADE/EDIT))))
(DEFINEQ
(SHADE/CREATE
(LAMBDA (PTYPE) (EDITSHADE)))
(SHADE/EDIT
(LAMBDA (PTYPE OBJECT) (EDITSHADE OBJECT)))
)
(READ.PTYPE STRING 1)
(\TYPE PTYPE NAME STRING COMMENT "A string" OTHER (FNS ((CREATE STRING/CREATE) (EDIT STRING/EDIT))
))
(DEFINEQ
(STRING/CREATE
(LAMBDA (TYPE) (TEDIT.STRING "Edit this string into what you want")))
(STRING/EDIT
(LAMBDA (TYPE OBJECT) (TEDIT.STRING OBJECT)))
)
(READ.PTYPE STRUCTURE 1)
(\TYPE PTYPE NAME STRUCTURE COMMENT "A structure" OTHER (FNS ((CREATE STRUCTURE/CREATE) (EDIT
STRUCTURE/EDIT) (WALK STRUCTURE/WALK))))
(DEFINEQ
(STRUCTURE/CREATE
(LAMBDA (TYPE) (CREATE.STRUCTURE (CADR TYPE))))
(STRUCTURE/EDIT
(LAMBDA (TYPE OBJECT) (EDIT.FORM OBJECT)))
(STRUCTURE/WALK
[LAMBDA (STRUCTURE PTYPE CONTEXT ACTIONFN ACTIONFNARG) (* HaKo "15-Aug-84 14:02")
(for FIELD in (CADR PTYPE) as OBJECT in STRUCTURE bind (RESULT (NEWCONTEXT ←(LIST STRUCTURE
CONTEXT)))
when (SETQ RESULT (WALK.OBJECT OBJECT (CADR FIELD)
NEWCONTEXT ACTIONFN ACTIONFNARG))
do (RETURN RESULT])
)
(RPAQ TRILLIUM.X.BITMAP (READBITMAP))
(14 14
"@@@@"
"D@A@"
"N@CH"
"G@G@"
"CHN@"
"AML@"
"@OH@"
"@G@@"
"@OH@"
"AML@"
"CHN@"
"G@G@"
"N@CH"
"D@A@")
(PUTPROPS BASIC-PTYPES COPYRIGHT ("Xerox Corporation" 1984))
(DECLARE: DONTCOPY
(FILEMAP (NIL (817 1558 (BITMAP/CREATE 827 . 1493) (BITMAP/EDIT 1495 . 1556)) (1686 3640 (
BITMAP.NAME/CREATE 1696 . 3638)) (3745 4243 (CELL/CREATE 3755 . 4241)) (4367 4466 (COLOR.NAME/CREATE
4377 . 4464)) (4598 4790 (COLOR.NUMBER/CREATE 4608 . 4788)) (4941 5117 (COMPUTED.VALUE/CREATE 4951 .
5115)) (5233 5380 (CONSTANT/CREATE 5243 . 5378)) (5488 5585 (COPY/CREATE 5498 . 5583)) (5696 7078 (
FONT/CREATE 5706 . 7076)) (7201 7415 (FORM/CREATE 7211 . 7327) (FORM/EDIT 7329 . 7413)) (7519 7671 (
FRAME/CREATE 7529 . 7669)) (7833 8053 (FRAME.CLASSES/CREATE 7843 . 7939) (FRAME.CLASSES/EDIT 7941 .
8051)) (8236 9893 (CREATE.GRIDREGION 8246 . 9446) (TRANSLATE.GRIDREGION 9448 . 9891)) (10006 10099 (
INTEGER/CREATE 10016 . 10097)) (10249 10642 (ITEM/CREATE 10259 . 10430) (ITEM/EDIT 10432 . 10498) (
ITEM/WALK 10500 . 10640)) (10808 11035 (ITYPE.CLASSES/CREATE 10818 . 10918) (ITYPE.CLASSES/EDIT 10920
. 11033)) (11172 11693 (LIST/CREATE 11182 . 11271) (LIST/EDIT 11273 . 11342) (LIST/WALK 11344 . 11691
)) (11866 13158 (LOCATION/CREATE 11876 . 12790) (LOCATION/LTRANSLATE 12792 . 13156)) (13383 15279 (
LOCATION2/CREATE 13393 . 13701) (LOCATION2/LTRANSLATE 13703 . 14128) (CREATE.LOCATION.WITH.BANDING
14130 . 15277)) (15447 16465 (OFFSET.VECTOR/CREATE 15457 . 16023) (FLIP.X 16025 . 16463)) (16570 16643
(ONEOF/CREATE 16580 . 16641)) (16814 18009 (POSITION/CREATE 16824 . 17607) (POSITION/TRANSLATE 17609
. 18007)) (18209 19188 (POSITION2/CREATE 18219 . 18537) (POSITION2/TRANSLATE 18539 . 19186)) (19299
19387 (QUOTE/CREATE 19309 . 19385)) (19865 23336 (REGION/CREATE 19875 . 19955) (REGION/TRANSLATE 19957
. 20537) (REGION/LEFT 20539 . 20606) (REGION/RIGHT 20608 . 20749) (REGION/BOTTOM 20751 . 20850) (
REGION/TOP 20852 . 20994) (REGION/WIDTH 20996 . 21093) (REGION/HEIGHT 21095 . 21194) (REGION/CENTER
21196 . 21476) (REGION/NORTH 21478 . 21746) (REGION/NORTHEAST 21748 . 22009) (REGION/EAST 22011 .
22278) (REGION/SOUTHEAST 22280 . 22495) (REGION/SOUTH 22497 . 22719) (REGION/SOUTHWEST 22721 . 22892)
(REGION/WEST 22894 . 23116) (REGION/NORTHWEST 23118 . 23334)) (23469 23589 (SHADE/CREATE 23479 . 23526
) (SHADE/EDIT 23528 . 23587)) (23718 23882 (STRING/CREATE 23728 . 23816) (STRING/EDIT 23818 . 23880))
(24049 24588 (STRUCTURE/CREATE 24059 . 24128) (STRUCTURE/EDIT 24130 . 24192) (STRUCTURE/WALK 24194 .
24586)))))
STOP