(FILECREATED "19-Nov-84 17:48:09" {AZTEC}<TRILLIUM>BIRTHDAY84>RERELEASE>TRI-EDITITYPE.;2 32125
changes to: (FNS EDIT.ITEM.TYPES GET.ITEM.TYPE.EDITOR.COMMAND.MENU)
previous date: "17-Aug-84 22:42:54" {AZTEC}<TRILLIUM>BIRTHDAY84>RERELEASE>TRI-EDITITYPE.;1)
(PRETTYCOMPRINT TRI-EDITITYPECOMS)
(RPAQQ TRI-EDITITYPECOMS ((FNS COPY.ITEM.TYPE CREATE.ITEM.TYPE DEFINE.ITEM.TYPE DELETE.ITEM.TYPE
EDIT.ITEM.TYPE EDIT.ITEM.TYPE.DESCRIPTION EDIT.ITEM.TYPES
GET.DEFINE.ITEM.TYPE.COMMAND.MENU GET.ITEM.TYPE.EDITOR.COMMAND.MENU
GRAPH.ITEM.TYPES MAKE.ITEMTYPE.DESCRIPTION.FROM.PROTOTYPE
MAKE.ITEMTYPE.DESCRIPTION.LEAST.GENERAL
MAKE.ITEMTYPE.DESCRIPTION.MOST.GENERAL
MAKE.ITEMTYPE.DESCRIPTION.NO.PROTOTYPE
MAKE.ITEMTYPE.DESCRIPTION.PROTOTYPE MAKE.PARAMETER.NAMES
MAKE.SUBITEM.SPECS MAKE.SUBITEM.SPECS.FROM.PROTOTYPE
MAKE.SUBITEM.SPECS.LEAST.GENERAL MISSING.ITYPE.FN MARK.ITEM.TYPE
MODIFY.ITEM.TYPE PARAMETER.NAMES PRINT.ITEM.TYPE REDEFINE.ITEM.TYPE
SPECIALIZE.ITEM.TYPE)
(VARS (ITEM.TYPE.MENU)
(ITEM.TYPE.GRAPH.WINDOW)
(ITEM.TYPE.EDITOR.COMMAND.MENU))))
(DEFINEQ
(COPY.ITEM.TYPE
[LAMBDA NIL (* HaKo "16-Aug-84 14:56")
(DECLARE (GLOBALVARS ITEM.TYPES))
(PROG (ITYPE NEW.ITYPE NEW.DESCRIPTION)
(TRILLIUM.PRINTOUT ON PROMPTWINDOW "Indicate item type to be copied")
(SETQ ITYPE (ACQUIRE.ITEM.TYPE))
(COND
((NULL ITYPE)
(RETURN)))
(TRILLIUM.PRINTOUT ON TRILLIUM.TRACE "Copying item type " ITYPE)
(TRILLIUM.PRINTOUT ON PROMPTWINDOW "Name of copy: ")
(SETQ NEW.ITYPE (PROMPT.READ))
(COND
((NULL NEW.ITYPE)
(TRILLIUM.PRINTOUT ON TRILLIUM.WARNINGS "Copy command aborted"))
((NOT (ATOM NEW.ITYPE))
(TRILLIUM.PRINTOUT ON TRILLIUM.WARNINGS "Name must be one word"))
((MEMBER NEW.ITYPE ITEM.TYPES)
(TRILLIUM.PRINTOUT ON TRILLIUM.WARNINGS "The name " NEW.ITYPE " is already in use"))
(T (SETQ NEW.DESCRIPTION (COPYALL (ITEM.TYPE.DESCRIPTION ITYPE)))
(SET.FIELDQ NEW.DESCRIPTION NAME NEW.ITYPE ITEM.TYPE)
(REGISTER.ITEM.TYPE NEW.ITYPE NEW.DESCRIPTION)
(MARK.ITEM.TYPE NEW.ITYPE T)
(TRILLIUM.PRINTOUT ON TRILLIUM.TRACE "Item type " NEW.ITYPE " created")
(RETURN NEW.ITYPE])
(CREATE.ITEM.TYPE
[LAMBDA NIL (* HaKo "25-Jul-84 16:17")
(DECLARE (GLOBALVARS ITEM.TYPES))
(PROG (NEW.NAME NEW.DESCRIPTION)
(TRILLIUM.PRINTOUT ON PROMPTWINDOW "Creating new item.type with name: ")
(SETQ NEW.NAME (PROMPT.READ))
(COND
((NULL NEW.NAME)
(RETURN))
((NOT (ATOM NEW.NAME))
(TRILLIUM.PRINTOUT ON TRILLIUM.WARNINGS "Name must be one word")
(RETURN))
((MEMBER NEW.NAME ITEM.TYPES)
(TRILLIUM.PRINTOUT ON TRILLIUM.WARNINGS "The name " NEW.NAME " is already in use")
(RETURN))
(T (SETQ NEW.DESCRIPTION (ITEM.CREATE ITEM.TYPE (NAME NEW.NAME)
(COMMENT "English description of this item type")
(KIND (QUOTE COMPOSITE))
[PARAMETERS
(LIST (ITEM.CREATE PARAMETER (NAME (QUOTE
PLACEMENT))
(TYPE (LIST (QUOTE REGION)))
(COMMENT
"The position of this item")
(DEFAULT (LIST 0 0 100 100)))
(ITEM.CREATE PARAMETER (NAME (QUOTE
PARAMETER.2))
(TYPE (LIST (QUOTE CONSTANT)))
(COMMENT
"User defined parameters")
(DEFAULT (QUOTE FOO]
(SUBITEM.SPECS NIL)
(OTHER NIL)))
(REGISTER.ITEM.TYPE NEW.NAME NEW.DESCRIPTION)
(MARK.ITEM.TYPE NEW.NAME T)
(EDIT.ITEM.TYPE.DESCRIPTION NEW.NAME)
(RETURN NEW.NAME])
(DEFINE.ITEM.TYPE
[LAMBDA NIL (* HaKo "16-Aug-84 14:57")
(DECLARE (SPECVARS FRAME)
(GLOBALVARS CURRENT.FRAME ITEM.TYPES))
(PROG (EXAMPLE.ITEM PROTOTYPE.ITEM NEW.NAME OLD.ITYPE OLD.DESCRIPTION NEW.DESCRIPTION ITEMS
ANALYSIS.FN ANALYSIS.FN.NAME RESET.FN RESET.FN.NAME)
(SETQ EXAMPLE.ITEM (ACQUIRE.ITEM CURRENT.FRAME "Indicate the example item"))
(COND
((NULL EXAMPLE.ITEM))
(T (SETQ PROTOTYPE.ITEM (ACQUIRE.ITEM CURRENT.FRAME "Indicate the prototype item"))
(TRILLIUM.PRINTOUT ON PROMPTWINDOW "Defining new item type with name: ")
(SETQ NEW.NAME (PROMPT.READ))
(COND
((NULL NEW.NAME)
(TRILLIUM.PRINTOUT ON TRILLIUM.WARNINGS " ... create aborted.")
(RETURN))
((NOT (ATOM NEW.NAME))
(TRILLIUM.PRINTOUT ON TRILLIUM.WARNINGS "Name must be one word")
(RETURN))
((MEMBER NEW.NAME ITEM.TYPES)
(TRILLIUM.PRINTOUT ON TRILLIUM.WARNINGS "The name " NEW.NAME " is already in use")
(RETURN))
(T (THINKING (RESET.ITEM EXAMPLE.ITEM)
(ANALYZE.ITEM EXAMPLE.ITEM)
[SETQ NEW.DESCRIPTION (COND
(PROTOTYPE.ITEM (MAKE.ITEMTYPE.DESCRIPTION.PROTOTYPE NEW.NAME
EXAMPLE.ITEM
PROTOTYPE.ITEM))
(T (MAKE.ITEMTYPE.DESCRIPTION.NO.PROTOTYPE NEW.NAME EXAMPLE.ITEM]
(RESET.ITEM EXAMPLE.ITEM)
(ANALYZE&COMPLETE.ITEM EXAMPLE.ITEM)
(REGISTER.ITEM.TYPE NEW.NAME NEW.DESCRIPTION)
(MARK.ITEM.TYPE NEW.NAME T)
(TRILLIUM.PRINTOUT ON TRILLIUM.TRACE "Item type " NEW.NAME " created")
(UPDATE&DISPLAY.FRAME FRAME))
(RETURN NEW.NAME])
(DELETE.ITEM.TYPE
[LAMBDA (DIALOG.NAME) (* HaKo "16-Aug-84 14:57")
(PROG ((ITYPE (ACQUIRE.ITEM.TYPE)))
(COND
((NULL ITYPE))
((NOT (CONFIRM (CONCAT "Delete item type " ITYPE "?")))
(TRILLIUM.PRINTOUT ON TRILLIUM.WARNINGS "Delete item type command aborted"))
(T (UNREGISTER.ITEM.TYPE ITYPE)
(UNMARKASCHANGED ITYPE (QUOTE ITEMTYPES))
(TRILLIUM.PRINTOUT ON TRILLIUM.TRACE "Item type " ITYPE " deleted"])
(EDIT.ITEM.TYPE
[LAMBDA NIL (* HK "15-JUL-82 16:02")
(PROG ((ITYPE (ACQUIRE.ITEM.TYPE)))
(COND
(ITYPE (EDIT.ITEM.TYPE.DESCRIPTION ITYPE)
(RETURN ITYPE])
(EDIT.ITEM.TYPE.DESCRIPTION
[LAMBDA (ITYPE) (* DAHJr " 5-DEC-83 12:23")
(COND
((KEYDOWNP (QUOTE LSHIFT))
(ITEM.TYPE.WINDOW.CREATE ITYPE))
(T (PROG (STARTING.DESCRIPTION NEW.DESCRIPTION)
(SETQ STARTING.DESCRIPTION (ITEM.TYPE.DESCRIPTION ITYPE))
(SETQ NEW.DESCRIPTION (COPYALL STARTING.DESCRIPTION))
(SETQ NEW.DESCRIPTION (DEDIT.FORM NEW.DESCRIPTION))
(COND
((NOT (EQUAL NEW.DESCRIPTION STARTING.DESCRIPTION))
(MODIFY.ITEM.TYPE ITYPE STARTING.DESCRIPTION NEW.DESCRIPTION)
(RETURN ITYPE))
(T (RETURN])
(EDIT.ITEM.TYPES
[LAMBDA NIL (* kkm "19-Nov-84 16:00")
(* DAHJr " 8-APR-83 12:12")
(* "Top level of the editor")
(do (SELECTQ (MENU (GET.ITEM.TYPE.EDITOR.COMMAND.MENU))
(NIL NIL)
(CREATE.NEW.ITEM.TYPE (CREATE.ITEM.TYPE))
(COPY.ITEM.TYPE (COPY.ITEM.TYPE))
(EDIT.ITEM.TYPE (EDIT.ITEM.TYPE))
(DELETE.ITEM.TYPE (DELETE.ITEM.TYPE))
(SPECIALIZE.ITEM.TYPE (SPECIALIZE.ITEM.TYPE))
(PRINT.ITEM.TYPES (PRINT.ITEM.TYPES))
(COMPILE.ITEMTYPE.FNS (COMPILE.INTERNAL.FNS))
(GRAPH.ITEM.TYPES (GRAPH.ITEM.TYPES))
(QUIT (RETURN NIL))
(SHOULDNT])
(GET.DEFINE.ITEM.TYPE.COMMAND.MENU
[LAMBDA NIL (* edited: "22-Jun-84 17:42")
(* WHEN MENU CHANGES EVAL: (SETQ
DEFINE.ITEM.TYPE.COMMAND.MENU NIL))
(DECLARE (GLOBALVARS DEFINE.ITEM.TYPE.COMMAND.MENU))
(OR DEFINE.ITEM.TYPE.COMMAND.MENU (SETQ DEFINE.ITEM.TYPE.COMMAND.MENU
(create MENU
ITEMS ←(QUOTE (LEAST.GENERAL FROM.PROTOTYPE MOST.GENERAL))
TITLE ← "Itemtype characterization"
CENTERFLG ← T
CHANGEOFFSETFLG ← T])
(GET.ITEM.TYPE.EDITOR.COMMAND.MENU
[LAMBDA (FRAME) (* kkm "19-Nov-84 16:00")
(* DAHJr "17-FEB-83 11:56")
(DECLARE (GLOBALVARS ITEM.TYPE.EDITOR.COMMAND.MENU))
(OR ITEM.TYPE.EDITOR.COMMAND.MENU (SETQ ITEM.TYPE.EDITOR.COMMAND.MENU
(create MENU
TITLE ← "Item type editor"
ITEMS ←(QUOTE (CREATE.NEW.ITEM.TYPE COPY.ITEM.TYPE SPECIALIZE.ITEM.TYPE
EDIT.ITEM.TYPE DELETE.ITEM.TYPE
PRINT.ITEM.TYPES COMPILE.ITEMTYPE.FNS
GRAPH.ITEM.TYPES QUIT))
CENTERFLG ← T
CHANGEOFFSETFLG ← T])
(GRAPH.ITEM.TYPES
[LAMBDA NIL (* DAHJr "16-JAN-83 15:09")
(DECLARE (GLOBALVARS ITEM.TYPE.GRAPH.WINDOW ITEM.TYPES))
(COND
[(OR (NULL ITEM.TYPE.GRAPH.WINDOW)
(WINDOWPROP ITEM.TYPE.GRAPH.WINDOW (QUOTE OBSOLETE)))
(THINKING (PROG ((DESTINATIONS (for ITYPE in ITEM.TYPES join (LIST ITYPE 0)))
NODES ROOTS GRAPH)
(SETQ NODES (for ITYPE in ITEM.TYPES bind SONS
collect [SETQ SONS (INTERSECTION ITEM.TYPES
(REVERSE (OFFSPRING ITYPE]
[for SON in SONS
do (LISTPUT DESTINATIONS SON
(ADD1 (LISTGET DESTINATIONS SON]
(create GRAPHNODE
NODEID ← ITYPE
NODELABEL ← ITYPE
TONODES ← SONS)))
(SETQ ROOTS (for ITYPE in ITEM.TYPES when (NEQ (LISTGET DESTINATIONS ITYPE)
1)
collect ITYPE))
(SETQ GRAPH (LAYOUTFOREST NODES (REVERSE ROOTS)
(QUOTE HORIZONTAL)
(QUOTE NOT/LEAVES)))
(SETQ ITEM.TYPE.GRAPH.WINDOW (SHOWGRAPH GRAPH ITEM.TYPE.GRAPH.WINDOW
(QUOTE GRAPH.LEFTBUTTONFN)
(QUOTE GRAPH.MIDDLEBUTTONFN)))
(WINDOWPROP ITEM.TYPE.GRAPH.WINDOW (QUOTE CURSORINFN)
(QUOTE GRAPH.WINDOW.CURSORINFN))
(RETURN T]
(T (TOTOPW ITEM.TYPE.GRAPH.WINDOW)
NIL])
(MAKE.ITEMTYPE.DESCRIPTION.FROM.PROTOTYPE
[LAMBDA (NEW.NAME EXAMPLE.ITEM PROTOTYPE.ITEM) (* HaKo " 7-Aug-84 12:42")
(PROG (ITEMS OLD.ITYPE OLD.DESCRIPTION OLD.PARAMETERS PROTOTYPE.BB PROTOTYPE.LEFT
PROTOTYPE.BOTTOM PARAMETERS PLACEMENT.PARAMETER PTYPE TRANSLATE.FN PLACEMENT.NAME
PNAME PTYPE TR.FN PLACEMENT.VALUE PLACEMENT.POSITION PDX PDY TRANSLATE.FN
SUBITEM.SPECS NEW.DESCRIPTION DX DY)
(SETQ ITEMS (GET.FIELDQ EXAMPLE.ITEM SUBITEMS))
(SETQ OLD.ITYPE (ITEM.TYPE PROTOTYPE.ITEM))
(SETQ OLD.DESCRIPTION (ITEM.TYPE.DESCRIPTION OLD.ITYPE))
(SETQ OLD.PARAMETERS (GET.FIELDQ OLD.DESCRIPTION PARAMETERS))
(SETQ PROTOTYPE.BB (BOUNDING.BOX PROTOTYPE.ITEM))
(SETQ PROTOTYPE.LEFT (fetch (REGION LEFT) of PROTOTYPE.BB))
(SETQ PROTOTYPE.BOTTOM (fetch (REGION BOTTOM) of PROTOTYPE.BB))
[SETQ PARAMETERS (for PARAMETER in OLD.PARAMETERS
collect (SETQ PNAME (GET.FIELDQ PARAMETER NAME))
(ITEM.CREATE PARAMETER (NAME PNAME)
(TYPE (COPYALL (GET.FIELDQ PARAMETER TYPE)))
(DEFAULT (COPYALL (GET.PARAM PROTOTYPE.ITEM PNAME))
)
(COMMENT (COPYALL (GET.FIELDQ PARAMETER COMMENT]
[SETQ PLACEMENT.PARAMETER (for PARAMETER in OLD.PARAMETERS
thereis (SETQ PTYPE (GET.FIELDQ PARAMETER TYPE))
(SETQ TRANSLATE.FN (FUNCTION.FOR.PTYPE (CAR PTYPE)
(QUOTE
TRANSLATE]
[COND
(PLACEMENT.PARAMETER (SETQ PLACEMENT.NAME (GET.FIELDQ PLACEMENT.PARAMETER NAME))
(SETQ PLACEMENT.VALUE (GET.PARAM PROTOTYPE.ITEM PLACEMENT.NAME))
(SETQ PLACEMENT.POSITION (APPLY* TRANSLATE.FN PLACEMENT.VALUE))
(SETQ DX (IDIFFERENCE (fetch (POSITION XCOORD) of PLACEMENT.POSITION)
PROTOTYPE.LEFT))
(SETQ DY (IDIFFERENCE (fetch (POSITION YCOORD) of PLACEMENT.POSITION)
PROTOTYPE.BOTTOM)))
(T (SETQ PLACEMENT.POSITION (create POSITION
XCOORD ← 0
YCOORD ← 0))
(SETQ PLACEMENT.PARAMETER (ITEM.CREATE PARAMETER (NAME (QUOTE PLACEMENT))
(TYPE (LIST (QUOTE POSITION)))
(DEFAULT PLACEMENT.POSITION)
(COMMENT "A reference point")))
(SETQ TRANSLATE.FN (FUNCTION.FOR.PTYPE (QUOTE POSITION)
(QUOTE TRANSLATE)))
(SETQ DX 0)
(SETQ DY 0)
(SETQ PARAMETERS (CONS PLACEMENT.PARAMETER PARAMETERS]
(SETQ SUBITEM.SPECS (MAKE.SUBITEM.SPECS.FROM.PROTOTYPE PARAMETERS PLACEMENT.PARAMETER
TRANSLATE.FN DX DY EXAMPLE.ITEM
PROTOTYPE.ITEM))
(SETQ NEW.DESCRIPTION (ITEM.CREATE ITEM.TYPE (NAME NEW.NAME)
(COMMENT (CONCAT "<A description of the item.type "
NEW.NAME ">"))
(KIND (QUOTE COMPOSITE))
(PARAMETERS PARAMETERS)
(CLASSES (GET.FIELDQ OLD.DESCRIPTION CLASSES))
(SUBITEM.SPECS SUBITEM.SPECS)))
(RETURN NEW.DESCRIPTION])
(MAKE.ITEMTYPE.DESCRIPTION.LEAST.GENERAL
[LAMBDA (NEW.NAME EXAMPLE.ITEM) (* edited: "23-Jun-84 17:21")
(DECLARE (SPECVARS OLD.DESCRIPTION))
(PROG (EXAMPLE.BB EXAMPLE.LEFT EXAMPLE.BOTTOM PLACEMENT.POSITION PLACEMENT.PARAMETER PDX PDY
SUBITEM.SPECS NEW.DESCRIPTION)
(SETQ EXAMPLE.BB (BOUNDING.BOX EXAMPLE.ITEM))
(SETQ EXAMPLE.LEFT (fetch (REGION LEFT) of EXAMPLE.BB))
(SETQ EXAMPLE.BOTTOM (fetch (REGION BOTTOM) of EXAMPLE.BB))
(SETQ PLACEMENT.POSITION (create POSITION
XCOORD ← 0
YCOORD ← 0)) (* OFFSET OF REFERENCE POSITION RELATIVE TO THE
LEFT-BOTTOM OF THE BOUNDING BOX)
(SETQ PLACEMENT.PARAMETER (ITEM.CREATE PARAMETER (NAME (QUOTE PLACEMENT))
(TYPE (LIST (QUOTE POSITION)))
(DEFAULT PLACEMENT.POSITION)
(COMMENT "A reference point")))
(* OFFSET FROM ORIGIN OF REFERENCE POSITION)
(SETQ PDX (IPLUS (fetch (POSITION XCOORD) of PLACEMENT.POSITION)
EXAMPLE.LEFT))
(SETQ PDY (IPLUS (fetch (POSITION YCOORD) of PLACEMENT.POSITION)
EXAMPLE.BOTTOM))
(SETQ SUBITEM.SPECS (MAKE.SUBITEM.SPECS.LEAST.GENERAL EXAMPLE.ITEM PLACEMENT.PARAMETER PDX
PDY))
(SETQ NEW.DESCRIPTION (ITEM.CREATE ITEM.TYPE (NAME NEW.NAME)
(COMMENT (CONCAT "<A description of the item.type "
NEW.NAME ">"))
(KIND (QUOTE COMPOSITE))
(PARAMETERS (LIST PLACEMENT.PARAMETER))
(CLASSES (GET.FIELDQ OLD.DESCRIPTION CLASSES))
(SUBITEM.SPECS SUBITEM.SPECS)))
(RETURN NEW.DESCRIPTION])
(MAKE.ITEMTYPE.DESCRIPTION.MOST.GENERAL
[LAMBDA (NEW.NAME EXAMPLE.ITEM) (* HaKo "27-Jul-84 16:49")
(PROG (ITEMS ITEM.NAMES PARAMETER.NAMES SUBITEM.SPECS ITEM ITYPE PARAMETERS NEW.DESCRIPTION)
(SETQ ITEMS (GET.FIELDQ EXAMPLE.ITEM SUBITEMS)) (* GETS A LIST OF (ITEM NAME))
(SETQ ITEM.NAMES (MAKE.ITEM.NAMES ITEMS)) (* GETS A LIST OF (ITEM NAME
(LIST OF (PARAMETER NAME))))
(SETQ PARAMETER.NAMES (MAKE.PARAMETER.NAMES ITEM.NAMES))
[SETQ SUBITEM.SPECS (for ITM in PARAMETER.NAMES
collect (SETQ ITEM (CAR ITM))
(SETQ ITYPE (ITEM.TYPE ITEM))
(BQUOTE (ITEM , ITYPE ,. (for PAR in (CADDR ITM)
collect
(LIST (GET.FIELDQ (CAR PAR)
NAME)
(CDR PAR]
[SETQ PARAMETERS (for ITM in PARAMETER.NAMES
join (for PAR in (CADDR ITM)
collect (ITEM.CREATE PARAMETER (NAME (CDR PAR))
(TYPE (COPYALL (GET.FIELDQ (CAR PAR)
TYPE)))
[DEFAULT
(COPYALL (GET.PARAM (CAR ITM)
(GET.FIELDQ
(CAR PAR)
NAME]
(COMMENT (COPYALL (GET.FIELDQ
(CAR PAR)
COMMENT]
(SETQ NEW.DESCRIPTION (ITEM.CREATE ITEM.TYPE (NAME NEW.NAME)
(KIND (QUOTE COMPOSITE))
(COMMENT (CONCAT "<A description of the item.type "
NEW.NAME ">"))
(PARAMETERS PARAMETERS)
(SUBITEM.SPECS SUBITEM.SPECS)))
(RETURN NEW.DESCRIPTION])
(MAKE.ITEMTYPE.DESCRIPTION.NO.PROTOTYPE
[LAMBDA (NEW.NAME EXAMPLE.ITEM) (* HaKo "27-Jul-84 16:49")
(PROG (ITEMS ITEM.NAMES PARAMETER.NAMES SUBITEM.SPECS ITEM ITYPE PARAMETERS NEW.DESCRIPTION)
(SETQ ITEMS (GET.FIELDQ EXAMPLE.ITEM SUBITEMS)) (* GETS A LIST OF ITEM/NAME PAIRS)
(SETQ ITEM.NAMES (MAKE.ITEM.NAMES ITEMS)) (* GETS A LIST OF (ITEM NAME
(LIST OF PARAMETER/NAME PAIRS)))
(SETQ PARAMETER.NAMES (MAKE.PARAMETER.NAMES ITEM.NAMES))
[SETQ SUBITEM.SPECS (for ITM in PARAMETER.NAMES
collect (SETQ ITEM (CAR ITM))
(SETQ ITYPE (ITEM.TYPE ITEM))
(BQUOTE (ITEM , ITYPE ,. (for PAR in (CADDR ITM)
collect
(LIST (GET.FIELDQ (CAR PAR)
NAME)
(CDR PAR]
[SETQ PARAMETERS (for ITM in PARAMETER.NAMES
join (for PAR in (CADDR ITM)
collect (ITEM.CREATE PARAMETER (NAME (CDR PAR))
(TYPE (COPYALL (GET.FIELDQ (CAR PAR)
TYPE)))
[DEFAULT
(COPYALL (GET.PARAM (CAR ITM)
(GET.FIELDQ
(CAR PAR)
NAME]
(COMMENT (COPYALL (GET.FIELDQ
(CAR PAR)
COMMENT]
(SETQ NEW.DESCRIPTION (ITEM.CREATE ITEM.TYPE (NAME NEW.NAME)
(KIND (QUOTE COMPOSITE))
(COMMENT (CONCAT "<A description of the item.type "
NEW.NAME ">"))
(PARAMETERS PARAMETERS)
(SUBITEM.SPECS SUBITEM.SPECS)))
(RETURN NEW.DESCRIPTION])
(MAKE.ITEMTYPE.DESCRIPTION.PROTOTYPE
[LAMBDA (NEW.NAME EXAMPLE.ITEM PROTOTYPE.ITEM) (* HaKo "27-Jul-84 16:50")
(PROG (ITEMS OLD.ITYPE OLD.DESCRIPTION OLD.PARAMETERS PLACEMENT.PARAMETER PTYPE TRANSLATE.FN
PLACEMENT.NAME PROTOTYPE.BB DX DY PNAME PTYPE TR.FN PLACEMENT.VALUE
PLACEMENT.POSITION PARAMETERS PDX PDY TRANSLATE.FN SUBITEM.SPECS NEW.DESCRIPTION)
(SETQ ITEMS (GET.FIELDQ EXAMPLE.ITEM SUBITEMS))
(SETQ OLD.ITYPE (ITEM.TYPE PROTOTYPE.ITEM))
(SETQ OLD.DESCRIPTION (ITEM.TYPE.DESCRIPTION OLD.ITYPE))
(SETQ OLD.PARAMETERS (GET.FIELDQ OLD.DESCRIPTION PARAMETERS))
[SETQ PLACEMENT.PARAMETER (for PARAMETER in OLD.PARAMETERS
thereis (SETQ PTYPE (GET.FIELDQ PARAMETER TYPE))
(SETQ TRANSLATE.FN (FUNCTION.FOR.PTYPE (CAR PTYPE)
(QUOTE
TRANSLATE]
(COND
(PLACEMENT.PARAMETER (SETQ PLACEMENT.NAME (GET.FIELDQ PLACEMENT.PARAMETER NAME))
(SETQ PROTOTYPE.BB (BOUNDING.BOX PROTOTYPE.ITEM))
(SETQ DX (fetch (REGION LEFT) of PROTOTYPE.BB))
(SETQ DY (fetch (REGION BOTTOM) of PROTOTYPE.BB)))
(T (SETQ DX 0)
(SETQ DY 0)))
[SETQ PARAMETERS (for PARAMETER in OLD.PARAMETERS
collect (SETQ PNAME (GET.FIELDQ PARAMETER NAME))
(SETQ PTYPE (GET.FIELDQ PARAMETER TYPE))
[SETQ TR.FN (COND
((NLISTP PTYPE)
NIL)
(T (FUNCTION.FOR.PTYPE (CAR PTYPE)
(QUOTE TRANSLATE]
(ITEM.CREATE PARAMETER (NAME PNAME)
(TYPE (COPYALL PTYPE))
[DEFAULT (COND
(TR.FN (APPLY* TR.FN (GET.PARAM
PROTOTYPE.ITEM
PNAME)
(MINUS DX)
(MINUS DY)))
(T (COPYALL (GET.PARAM PROTOTYPE.ITEM
PNAME]
(COMMENT (COPYALL (GET.FIELDQ PARAMETER COMMENT]
[COND
(PLACEMENT.PARAMETER (SETQ PLACEMENT.VALUE (GET.PARAM PROTOTYPE.ITEM PLACEMENT.NAME))
(SETQ PLACEMENT.POSITION (APPLY* TRANSLATE.FN PLACEMENT.VALUE)))
(T (SETQ PLACEMENT.POSITION (create POSITION
XCOORD ← 0
YCOORD ← 0))
(SETQ PLACEMENT.PARAMETER (ITEM.CREATE PARAMETER (NAME (QUOTE PLACEMENT))
(TYPE (LIST (QUOTE POSITION)))
(DEFAULT PLACEMENT.POSITION)
(COMMENT "A reference point")))
(SETQ PARAMETERS (CONS PLACEMENT.PARAMETER PARAMETERS))
(SETQ TRANSLATE.FN (FUNCTION.FOR.PTYPE (QUOTE POSITION)
(QUOTE TRANSLATE]
(SETQ PDX (IDIFFERENCE (fetch (POSITION XCOORD) of PLACEMENT.POSITION)
DX))
(SETQ PDY (IDIFFERENCE (fetch (POSITION YCOORD) of PLACEMENT.POSITION)
DY))
(SETQ SUBITEM.SPECS (MAKE.SUBITEM.SPECS PARAMETERS PLACEMENT.PARAMETER TRANSLATE.FN PDX PDY
EXAMPLE.ITEM PROTOTYPE.ITEM))
(SETQ NEW.DESCRIPTION (ITEM.CREATE ITEM.TYPE (NAME NEW.NAME)
(COMMENT (CONCAT "<A description of the item.type "
NEW.NAME ">"))
(KIND (QUOTE COMPOSITE))
(PARAMETERS PARAMETERS)
(CLASSES (GET.FIELDQ OLD.DESCRIPTION CLASSES))
(SUBITEM.SPECS SUBITEM.SPECS)))
(RETURN NEW.DESCRIPTION])
(MAKE.PARAMETER.NAMES
[LAMBDA (ITEM.NAMES) (* DAHJr " 9-OCT-83 14:59")
(* RETURNS A LIST OF (ITEM NAME
(LIST OF PARAMETER/NAME PAIRS)))
(for AELEM in ITEM.NAMES bind ITEM ITYPE DESCRIPTION NAME (SIMPLE ←(EQ (LENGTH ITEM.NAMES)
1))
collect (SETQ ITEM (CAR AELEM))
(SETQ ITYPE (ITEM.TYPE ITEM))
(SETQ DESCRIPTION (ITEM.TYPE.DESCRIPTION ITYPE))
(SETQ NAME (CDR AELEM))
(LIST ITEM NAME (for PARAMETER in (GET.FIELDQ DESCRIPTION PARAMETERS)
collect (CONS PARAMETER (COND
(SIMPLE (GET.FIELDQ PARAMETER NAME))
(T (MKATOM (CONCAT NAME (GET.FIELDQ PARAMETER NAME])
(MAKE.SUBITEM.SPECS
[LAMBDA (PARAMETERS PLACEMENT.PARAMETER TRANSLATE.FN XOFFSET YOFFSET EXAMPLE.ITEM PROTOTYPE.ITEM)
(* HaKo "27-Jul-84 16:51")
(PROG (ITEMS EXAMPLE.BB DX DY PLACEMENT.PARAMETER.NAME PNAME ITYPE DESCR PARS VALUE PTYPE TR.FN
VALUE.EXPR AT.ORIGIN SAME.VALUE.PARAMETER)
(SETQ ITEMS (GET.FIELDQ EXAMPLE.ITEM SUBITEMS))
(SETQ EXAMPLE.BB (BOUNDING.BOX EXAMPLE.ITEM))
(SETQ DX (IDIFFERENCE XOFFSET (fetch (REGION LEFT) of EXAMPLE.BB)))
(SETQ DY (IDIFFERENCE YOFFSET (fetch (REGION BOTTOM) of EXAMPLE.BB)))
(SETQ PLACEMENT.PARAMETER.NAME (GET.FIELDQ PLACEMENT.PARAMETER NAME))
(RETURN (for ITEM in ITEMS
collect
(SETQ ITYPE (ITEM.TYPE ITEM))
(SETQ DESCR (ITEM.TYPE.DESCRIPTION ITYPE))
(SETQ PARS (GET.FIELDQ DESCR PARAMETERS))
(BQUOTE (ITEM , ITYPE ,.
(for PAR in PARS
when [PROGN (SETQ PNAME (GET.FIELDQ PAR NAME))
(SETQ PTYPE (GET.FIELDQ PAR TYPE))
(SETQ VALUE (GET.PARAM ITEM PNAME))
[SETQ SAME.VALUE.PARAMETER
(for PARAMETER in PARAMETERS
thereis (AND (EQUAL (GET.FIELDQ PARAMETER
TYPE)
PTYPE)
(EQUAL (GET.PARAM PROTOTYPE.ITEM
(GET.FIELDQ
PARAMETER
NAME))
VALUE]
(OR SAME.VALUE.PARAMETER (SETQ VALUE
(LISTGET ITEM PNAME]
collect [SETQ VALUE.EXPR
(COND
(SAME.VALUE.PARAMETER (GET.FIELDQ
SAME.VALUE.PARAMETER
NAME))
(T [SETQ TR.FN (COND
((NLISTP PTYPE)
NIL)
(T (FUNCTION.FOR.PTYPE (CAR PTYPE)
(QUOTE TRANSLATE]
(COND
(TR.FN (SETQ AT.ORIGIN
(APPLY* TR.FN VALUE DX DY))
(LIST TR.FN (KWOTE AT.ORIGIN)
PLACEMENT.PARAMETER.NAME))
(T (BQUOTE (COPY , (KWOTE (COPYALL VALUE]
(LIST PNAME VALUE.EXPR])
(MAKE.SUBITEM.SPECS.FROM.PROTOTYPE
[LAMBDA (PARAMETERS PLACEMENT.PARAMETER TRANSLATE.FN XOFFSET YOFFSET EXAMPLE.ITEM PROTOTYPE.ITEM)
(* HaKo "27-Jul-84 17:16")
(PROG (SUBITEMS EXAMPLE.BB DX DY PLACEMENT.PARAMETER.NAME PNAME ITYPE DESCR PARS VALUE PTYPE
TR.FN VALUE.EXPR AT.ORIGIN SAME.VALUE.PARAMETER)
(SETQ SUBITEMS (GET.FIELDQ EXAMPLE.ITEM SUBITEMS))
(SETQ EXAMPLE.BB (BOUNDING.BOX EXAMPLE.ITEM))
[SETQ DX (IMINUS (IPLUS XOFFSET (fetch (REGION LEFT) of EXAMPLE.BB]
[SETQ DY (IMINUS (IPLUS YOFFSET (fetch (REGION BOTTOM) of EXAMPLE.BB]
(SETQ PLACEMENT.PARAMETER.NAME (GET.FIELDQ PLACEMENT.PARAMETER NAME))
(RETURN (for ITEM in SUBITEMS
collect
(SETQ ITYPE (ITEM.TYPE ITEM))
(SETQ DESCR (ITEM.TYPE.DESCRIPTION ITYPE))
(SETQ PARS (GET.FIELDQ DESCR PARAMETERS))
(BQUOTE (ITEM , ITYPE ,.
(for PAR in PARS
when [PROGN (SETQ PNAME (GET.FIELDQ PAR NAME))
(SETQ PTYPE (GET.FIELDQ PAR TYPE))
(SETQ VALUE (GET.PARAM ITEM PNAME))
[SETQ SAME.VALUE.PARAMETER
(for PARAMETER in PARAMETERS
thereis (AND (EQUAL (GET.FIELDQ PARAMETER
TYPE)
PTYPE)
(EQUAL (GET.PARAM PROTOTYPE.ITEM
(GET.FIELDQ
PARAMETER
NAME))
VALUE]
(OR SAME.VALUE.PARAMETER (SETQ VALUE
(GET.FIELD ITEM PNAME]
collect [SETQ VALUE.EXPR
(COND
(SAME.VALUE.PARAMETER (GET.FIELDQ
SAME.VALUE.PARAMETER
NAME))
(T [SETQ TR.FN (COND
((NLISTP PTYPE)
NIL)
(T (FUNCTION.FOR.PTYPE (CAR PTYPE)
(QUOTE TRANSLATE]
(COND
(TR.FN (SETQ AT.ORIGIN
(APPLY* TR.FN VALUE DX DY))
(LIST TR.FN (KWOTE AT.ORIGIN)
(LIST TRANSLATE.FN
PLACEMENT.PARAMETER.NAME)))
(T (BQUOTE (COPY , (KWOTE (COPYALL VALUE]
(LIST PNAME VALUE.EXPR])
(MAKE.SUBITEM.SPECS.LEAST.GENERAL
[LAMBDA (EXAMPLE.ITEM PLACEMENT.PARAMETER XOFFSET YOFFSET)
(* HaKo "27-Jul-84 17:16")
(PROG (EXAMPLE.BB PLACEMENT.PARAMETER.NAME DX DY ITYPE DESCR PARS PNAME PTYPE VALUE TR.FN
VALUE.EXPR AT.ORIGIN)
(SETQ PLACEMENT.PARAMETER.NAME (GET.FIELDQ PLACEMENT.PARAMETER NAME))
(SETQ DX (MINUS XOFFSET))
(SETQ DY (MINUS YOFFSET))
(RETURN (for ITEM in (GET.FIELDQ EXAMPLE.ITEM SUBITEMS)
collect (SETQ ITYPE (ITEM.TYPE ITEM))
(SETQ DESCR (ITEM.TYPE.DESCRIPTION ITYPE))
(SETQ PARS (GET.FIELDQ DESCR PARAMETERS))
(BQUOTE (ITEM , ITYPE ,.
(for PAR in PARS when (PROGN (SETQ PNAME (GET.FIELDQ
PAR NAME))
(SETQ PTYPE (GET.FIELDQ
PAR TYPE))
(SETQ VALUE (GET.FIELD ITEM
PNAME)))
collect [SETQ TR.FN (COND
((NLISTP PTYPE)
NIL)
(T (FUNCTION.FOR.PTYPE (CAR PTYPE)
(QUOTE TRANSLATE]
[SETQ VALUE.EXPR
(COND
(TR.FN (SETQ AT.ORIGIN
(APPLY* TR.FN VALUE DX DY))
(LIST TR.FN (KWOTE AT.ORIGIN)
PLACEMENT.PARAMETER.NAME))
(T (BQUOTE (COPY , (KWOTE (COPYALL VALUE]
(LIST PNAME VALUE.EXPR])
(MISSING.ITYPE.FN
[LAMBDA (ITEM FNNAME) (* HaKo "26-Jul-84 15:14")
(TRILLIUM.PRINTOUT ON TRILLIUM.WARNINGS "No " FNNAME " function for item of type " (ITEM.TYPE
ITEM])
(MARK.ITEM.TYPE
[LAMBDA (ITYPE NEW) (* HaKo "16-Aug-84 14:58")
(DECLARE (GLOBALVARS TRILLIUM.MARKFLG))
(PROG ((TYPE (QUOTE ITEMTYPES)))
(COND
((NULL TRILLIUM.MARKFLG))
((MARKASCHANGEDP ITYPE TYPE))
(T (TRILLIUM.PRINTOUT ON TRILLIUM.TRACE "Marking item type " ITYPE " as changed")
(MARKASCHANGED ITYPE TYPE NEW])
(MODIFY.ITEM.TYPE
[LAMBDA (ITYPE OLD.DESCRIPTION NEW.DESCRIPTION) (* DAHJr " 9-OCT-83 16:03")
(DECLARE (GLOBALVARS ITEM.TYPE.GRAPH.WINDOW))
(THINKING (UNREGISTER.ITEM.TYPE ITYPE)
(REGISTER.ITEM.TYPE ITYPE NEW.DESCRIPTION)
(MARK.ITEM.TYPE ITYPE)
(COND
[(OR (NULL ITEM.TYPE.GRAPH.WINDOW)
(EQUAL (OFFSPRING.OF.DESCRIPTION OLD.DESCRIPTION)
(OFFSPRING.OF.DESCRIPTION NEW.DESCRIPTION]
(T (GRAY.WINDOW ITEM.TYPE.GRAPH.WINDOW)
(WINDOWPROP ITEM.TYPE.GRAPH.WINDOW (QUOTE OBSOLETE)
T])
(PARAMETER.NAMES
[LAMBDA (DESCRIPTION) (* DAHJr "23-JUN-83 17:43")
(for PARAMETER in (CDR (GET.FIELDQ DESCRIPTION PARAMETERS ITEM.TYPE)) collect (GET.FIELDQ
PARAMETER
NAME])
(PRINT.ITEM.TYPE
[LAMBDA (ITYPE) (* HaKo "16-Aug-84 14:58")
(PROG (PARAMETER.NAMES FIELD.NAMES)
(TRILLIUM.PRINTOUT ON TRILLIUM.DESCRIPTIONS "Item type: " ITYPE)
(SETQ PARAMETER.NAMES (ITEM.TYPE.PARAMETER.NAMES ITYPE))
(for PARAMETER.NAME in PARAMETER.NAMES do (TRILLIUM.PRINTOUT ON TRILLIUM.DESCRIPTIONS " "
PARAMETER.NAME))
(RETURN])
(REDEFINE.ITEM.TYPE
[LAMBDA (ITYPE NEW.DESCRIPTION)
(UNINSTALL.ITEM.TYPE ITYPE)
(SET.ITEM.TYPE.DESCRIPTION ITYPE NEW.DESCRIPTION)
(INSTALL.ITEM.TYPE ITYPE])
(SPECIALIZE.ITEM.TYPE
[LAMBDA NIL (* HaKo "16-Aug-84 14:59")
(DECLARE (GLOBALVARS ITEM.TYPES))
(PROG (ITYPE NEW.ITYPE DESCRIPTION NEW.DESCRIPTION)
(TRILLIUM.PRINTOUT ON PROMPTWINDOW "Indicate item type to be specialized")
(OR (SETQ ITYPE (ACQUIRE.ITEM.TYPE))
(RETURN))
(TRILLIUM.PRINTOUT ON TRILLIUM.TRACE "Specializing item type " ITYPE)
(TRILLIUM.PRINTOUT ON PROMPTWINDOW "Name of new item type: ")
(SETQ NEW.ITYPE (PROMPT.READ))
(COND
((NULL NEW.ITYPE)
(TRILLIUM.PRINTOUT ON TRILLIUM.WARNINGS "Specialize command aborted")
(RETURN))
((NOT (ATOM NEW.ITYPE))
(TRILLIUM.PRINTOUT ON TRILLIUM.WARNINGS "Name must be one word")
(RETURN))
((MEMBER NEW.ITYPE ITEM.TYPES)
(TRILLIUM.PRINTOUT ON TRILLIUM.WARNINGS "The name " NEW.ITYPE " is already in use")
(RETURN))
(T (SETQ DESCRIPTION (ITEM.TYPE.DESCRIPTION ITYPE))
(SETQ NEW.DESCRIPTION (COPYALL DESCRIPTION))
(SET.FIELDQ NEW.DESCRIPTION NAME NEW.ITYPE ITEM.TYPE)
(SET.FIELDQ NEW.DESCRIPTION SUBITEM.SPECS [LIST (NCONC (LIST (QUOTE ITEM)
ITYPE)
(for PARAMETER
in (GET.FIELDQ DESCRIPTION
PARAMETERS
ITEM.TYPE)
bind PNAME
collect (SETQ PNAME
(GET.FIELDQ
PARAMETER
NAME))
(LIST PNAME PNAME]
ITEM.TYPE)
(REGISTER.ITEM.TYPE NEW.ITYPE NEW.DESCRIPTION)
(MARK.ITEM.TYPE NEW.ITYPE T)
(TRILLIUM.PRINTOUT ON TRILLIUM.TRACE "Item type " NEW.ITYPE " created")
(RETURN NEW.ITYPE])
)
(RPAQQ ITEM.TYPE.MENU NIL)
(RPAQQ ITEM.TYPE.GRAPH.WINDOW NIL)
(RPAQQ ITEM.TYPE.EDITOR.COMMAND.MENU NIL)
(DECLARE: DONTCOPY
(FILEMAP (NIL (1201 31984 (COPY.ITEM.TYPE 1211 . 2441) (CREATE.ITEM.TYPE 2443 . 3925) (
DEFINE.ITEM.TYPE 3927 . 5620) (DELETE.ITEM.TYPE 5622 . 6120) (EDIT.ITEM.TYPE 6122 . 6359) (
EDIT.ITEM.TYPE.DESCRIPTION 6361 . 6981) (EDIT.ITEM.TYPES 6983 . 7785) (
GET.DEFINE.ITEM.TYPE.COMMAND.MENU 7787 . 8373) (GET.ITEM.TYPE.EDITOR.COMMAND.MENU 8375 . 9036) (
GRAPH.ITEM.TYPES 9038 . 10441) (MAKE.ITEMTYPE.DESCRIPTION.FROM.PROTOTYPE 10443 . 13458) (
MAKE.ITEMTYPE.DESCRIPTION.LEAST.GENERAL 13460 . 15211) (MAKE.ITEMTYPE.DESCRIPTION.MOST.GENERAL 15213
. 16835) (MAKE.ITEMTYPE.DESCRIPTION.NO.PROTOTYPE 16837 . 18467) (MAKE.ITEMTYPE.DESCRIPTION.PROTOTYPE
18469 . 21723) (MAKE.PARAMETER.NAMES 21725 . 22515) (MAKE.SUBITEM.SPECS 22517 . 24608) (
MAKE.SUBITEM.SPECS.FROM.PROTOTYPE 24610 . 26761) (MAKE.SUBITEM.SPECS.LEAST.GENERAL 26763 . 28140) (
MISSING.ITYPE.FN 28142 . 28364) (MARK.ITEM.TYPE 28366 . 28771) (MODIFY.ITEM.TYPE 28773 . 29338) (
PARAMETER.NAMES 29340 . 29605) (PRINT.ITEM.TYPE 29607 . 30071) (REDEFINE.ITEM.TYPE 30073 . 30247) (
SPECIALIZE.ITEM.TYPE 30249 . 31982)))))
STOP