(FILECREATED "28-Feb-85 18:45:24" {PHYLUM}<TRILLIUM>BIRTHDAY84>FIXES>JAN-18-85-FIXES-COMPLETE.;5 48804
changes to: (VARS JAN-18-85-FIXES-COMPLETECOMS)
(FNS COPY.INTERFACE ACQUIRE.INTERFACE.NAME)
previous date: "18-Jan-85 19:20:12" {DSK2}JAN-18-85-FIXES-COMPLETE-FIXED.;1)
(* Copyright (c) 1985 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT JAN-18-85-FIXES-COMPLETECOMS)
(RPAQQ JAN-18-85-FIXES-COMPLETECOMS [(* * Henrietta fixes to Trillium source)
(* * FONTS.IN.CORE: Didn't search list by device type. If the
DISPLAY font type was not first in the list, it wouldn't be
included in the font menu.)
(FNS FONTS.IN.CORE.Original FONTS.IN.CORE)
(* * FORGET.FRAME.CLASS: Didn't reset CURRENT.BITMAP.FRAMES)
(FNS FORGET.FRAME.CLASS.Original FORGET.FRAME.CLASS)
(* * MOVE.ITEM: Flips all items in the frame while prompting for
item's new placement)
(FNS MOVE.ITEM.Original MOVE.ITEM)
(* * COPY.INTERFACE: Modified to copy the color map of the
interface, also)
(FNS COPY.INTERFACE.Original COPY.INTERFACE)
(* * Webster fixes to Trillium source)
(* * ACQUIRE.INTERFACE.NAME; Modified to inform user when no
interfaces have been loaded)
(FNS ACQUIRE.INTERFACE.NAME.Original ACQUIRE.INTERFACE.NAME)
(* * PARC fixes to Trillium source)
(* * SET.TRILLIUM.FILES.LOCATION modified to include only host
and release directory, and to end with >)
(FNS SET.TRILLIUM.FILES.LOCATION.Original
SET.TRILLIUM.FILES.LOCATION)
(* * TRILLIUM.MAKESYS modified to cause fix file loading when
sysout is restarted)
(FNS TRILLIUM.MAKESYS.Original TRILLIUM.MAKESYS)
(* * TRILLIUM.SET.SOURCE modified to make use of new var
TRILLIUM.SOURCE.SUBDIRECTORY)
(FNS TRILLIUM.SET.SOURCE.Original TRILLIUM.SET.SOURCE)
(* * TRILLIUM.LOAD.FIXES new function to do work of loading all
fix files)
(FNS TRILLIUM.LOAD.FIXES)
(* * TRILLIUM.LOAD.TRILLIUM? modified to make use of modified
TRILLIUM.FILENAME)
(FNS TRILLIUM.LOAD.TRILLIUM?.Original TRILLIUM.LOAD.TRILLIUM?)
(* * TRILLIUM.FILENAME modified to take argument indicating
which subdirectory of the release to take file from)
(FNS TRILLIUM.FILENAME.Original TRILLIUM.FILENAME)
(* * TRILLIUM.RELEASE.HOST/DIRECTORY Obsolete variable, set to
NOBIND)
(VARS TRILLIUM.RELEASE.HOST/DIRECTORY)
(* * *.SUBDIRECTORY new (global)
variables locating the subdirectories wherein various parts
of Trillium are kept)
(VARS TRILLIUM.SOURCE.SUBDIRECTORY TRILLIUM.PTYPE.SUBDIRECTORY
TRILLIUM.ITEMTYPE.SUBDIRECTORY TRILLIUM.FIX.SUBDIRECTORY
TRILLIUM.INTERFACE.SUBDIRECTORY)
(* * add itemtype and ptype to the list of objects included in a
LISTFILE index)
(ADDVARS (INDEXEDTYPESLST (ITEMTYPE READ.ITEMTYPE)
(PTYPE READ.PTYPE)))
(* * MAKE.ITEMTYPES.COMS and MAKE.PTYPES.COMS now add a comment
giving name of object)
(FNS MAKE.ITEMTYPES.COMS.Original MAKE.ITEMTYPES.COMS
MAKE.PTYPES.COMS.Original MAKE.PTYPES.COMS)
(* * LIST.OBJECTS.ON.FILE mustn't delete file before LISTFILES
is finished)
(FNS LIST.OBJECTS.ON.FILE.Original LIST.OBJECTS.ON.FILE)
(* * fixes to Trillium Itemtypes and Ptypes)
(* * LABELLED.BUTTON Changed default LABEL value to be "1"
instead of 1)
(ITEMTYPES LABELLED.BUTTON)
(* * INVERTING.CASCADE.LIGHT alignment values were inadvertently
quoted: D.Ingalls)
(ITEMTYPES INVERTING.CASCADE.LIGHT)
(* * Submitted by PatH: BITMAP.NAME/CREATE used
(LISTGET CURRENT.FRAME.CLASSES (QUOTE BITMAP.FRAMES))
instead of CURRENT.BITMAP.FRAMES)
(FNS BITMAP.NAME/CREATE.Original)
(PTYPES BITMAP.NAME)
(P (COMPILE.INTERNAL.FNS.IF.NECESSARY))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDVARS (NLAMA)
(NLAML MAKE.PTYPES.COMS
MAKE.PTYPES.COMS.Original
MAKE.ITEMTYPES.COMS
MAKE.ITEMTYPES.COMS.Original)
(LAMA])
(* * Henrietta fixes to Trillium source)
(* * FONTS.IN.CORE: Didn't search list by device type. If the DISPLAY font type was not first
in the list, it wouldn't be included in the font menu.)
(DEFINEQ
(FONTS.IN.CORE.Original
[LAMBDA NIL (* edited: " 4-DEC-82 15:28")
(DECLARE (GLOBALVARS \FONTSINCORE))
(for FAMILY in \FONTSINCORE join (for SIZE in (CDR FAMILY)
join (for FACE in (CDR SIZE)
when (EQ (CAR (CADR (CADR FACE)))
(QUOTE DISPLAY))
collect (LIST (CAR FAMILY)
(CAR SIZE)
(CAR FACE])
(FONTS.IN.CORE
[LAMBDA NIL (* edited: " 4-DEC-82 15:28")
(DECLARE (GLOBALVARS \FONTSINCORE))
(for FAMILY in \FONTSINCORE join (for SIZE in (CDR FAMILY)
join (for FACE in (CDR SIZE)
when (EQ (CAR (CADR (CADR FACE)))
(QUOTE DISPLAY))
collect (LIST (CAR FAMILY)
(CAR SIZE)
(CAR FACE])
)
(* * FORGET.FRAME.CLASS: Didn't reset CURRENT.BITMAP.FRAMES)
(DEFINEQ
(FORGET.FRAME.CLASS.Original
[LAMBDA (FRAME) (* HaKo "25-Jul-84 16:28")
(DECLARE (GLOBALVARS CURRENT.INTERFACE FRAME.NAME.MENU))
(PROG (FRAME.NAME CLASSES CLASS.NAME)
(SETQ FRAME.NAME (GET.FIELDQ FRAME NAME FRAME))
(SETQ CLASSES (GET.FIELDQ FRAME CLASSES))
(COND
((NULL CLASSES)
(TRILLIUM.PRINTOUT ON TRILLIUM.WARNINGS "This frame has no classes; can't forget one"))
(T (SETQ CLASS.NAME
(MENU (create MENU
ITEMS ← CLASSES
TITLE ← "Classes"
CENTERFLG ← T
CHANGEOFFSETFLG ← T)))
(COND
((AND CLASS.NAME (CONFIRM (CONCAT "Forget class" CLASS.NAME "?")))
(SET.FIELDQ FRAME CLASSES (REMOVE CLASS.NAME CLASSES))
(MARK.INTERFACE CURRENT.INTERFACE)
(SETQ FRAME.NAME.MENU)
(RETURN T))
(T (TRILLIUM.PRINTOUT ON TRILLIUM.WARNINGS "FORGET.FRAME.CLASS command aborted"])
(FORGET.FRAME.CLASS
[LAMBDA (FRAME) (* kkm "29-Nov-84 15:41")
(DECLARE (GLOBALVARS CURRENT.INTERFACE FRAME.NAME.MENU))
(PROG (FRAME.NAME CLASSES CLASS.NAME)
(SETQ FRAME.NAME (GET.FIELDQ FRAME NAME FRAME))
(SETQ CLASSES (GET.FIELDQ FRAME CLASSES))
(COND
((NULL CLASSES)
(TRILLIUM.PRINTOUT ON TRILLIUM.WARNINGS "This frame has no classes; can't forget one"))
(T (SETQ CLASS.NAME
(MENU (create MENU
ITEMS ← CLASSES
TITLE ← "Classes"
CENTERFLG ← T
CHANGEOFFSETFLG ← T)))
(COND
((AND CLASS.NAME (CONFIRM (CONCAT "Forget class" CLASS.NAME "?")))
(SET.FIELDQ FRAME CLASSES (REMOVE CLASS.NAME CLASSES))
(MARK.INTERFACE CURRENT.INTERFACE)
(SETQ FRAME.NAME.MENU)
(SETQ CURRENT.BITMAP.FRAMES)
(RETURN T))
(T (TRILLIUM.PRINTOUT ON TRILLIUM.WARNINGS "FORGET.FRAME.CLASS command aborted"])
)
(* * MOVE.ITEM: Flips all items in the frame while prompting for item's new placement)
(DEFINEQ
(MOVE.ITEM.Original
[LAMBDA (FRAME) (* HaKo "25-Jul-84 16:52")
(PROG (ITEM DELTA.POSITION OLD.POSITION)
(SETQ ITEM (ACQUIRE.ITEM FRAME "Point out the item to be moved"))
(COND
((NULL ITEM)
(TRILLIUM.PRINTOUT ON TRILLIUM.WARNINGS
"Cannot find any item where you pointed: move command aborted"))
((NOT (TYPE.DEFINEDP ITEM))
(TRILLIUM.PRINTOUT ON TRILLIUM.WARNINGS
"Can't move that item, as its type is undefined"))
(T (SETQ OLD.POSITION (BOUNDING.BOX ITEM))
(SETQ DELTA.POSITION (ACQUIRE.MOVED.PLACEMENT ITEM
"Indicate a new placement for the item"))
(THINKING (TRANSLATE.PLACEMENT ITEM DELTA.POSITION)
(ANALYZE&COMPLETE.ITEM ITEM FRAME)
(UPDATE&DISPLAY.FRAME FRAME ITEM OLD.POSITION))
(RETURN ITEM])
(MOVE.ITEM
[LAMBDA (FRAME) (* kkm "29-Nov-84 19:48")
(PROG (ITEM DELTA.POSITION OLD.POSITION)
(SETQ ITEM (ACQUIRE.ITEM FRAME "Point out the item to be moved"))
(COND
((NULL ITEM)
(TRILLIUM.PRINTOUT ON TRILLIUM.WARNINGS
"Cannot find any item where you pointed: move command aborted"))
((NOT (TYPE.DEFINEDP ITEM))
(TRILLIUM.PRINTOUT ON TRILLIUM.WARNINGS
"Can't move that item, as its type is undefined"))
(T (SETQ OLD.POSITION (BOUNDING.BOX ITEM))
(FLIP.ALL.ITEMS FRAME)
(SETQ DELTA.POSITION (ACQUIRE.MOVED.PLACEMENT ITEM
"Indicate a new placement for the item"))
(FLIP.ALL.ITEMS FRAME)
(THINKING (TRANSLATE.PLACEMENT ITEM DELTA.POSITION)
(ANALYZE&COMPLETE.ITEM ITEM FRAME)
(UPDATE&DISPLAY.FRAME FRAME ITEM OLD.POSITION))
(RETURN ITEM])
)
(* * COPY.INTERFACE: Modified to copy the color map of the interface, also)
(DEFINEQ
(COPY.INTERFACE.Original
[LAMBDA (INTERFACE) (* kkm " 2-Jan-85 17:03")
(PROG (NAME NEW.NAME NEW.INTERFACE FRAMES FIRST.FRAME REGION PROFILE BACKGROUND.COLOR)
(SETQ NAME (GET.FIELDQ INTERFACE NAME INTERFACE))
(TRILLIUM.PRINTOUT ON TRILLIUM.TRACE "Copying interface " NAME)
(TRILLIUM.PRINTOUT ON PROMPTWINDOW "Name of copy: ")
(SETQ NEW.NAME (PROMPT.READ))
(COND
((NULL NEW.NAME)
(TRILLIUM.PRINTOUT ON TRILLIUM.WARNINGS "Copy command aborted"))
((NOT (ATOM NEW.NAME))
(TRILLIUM.PRINTOUT ON TRILLIUM.WARNINGS "Name must be one word")
(RETURN))
((FIND.INTERFACE NEW.NAME)
(TRILLIUM.PRINTOUT ON TRILLIUM.WARNINGS "The name " NEW.NAME " is already in use")
(RETURN))
(T (SETQ FRAMES (for FRAME in (GET.FIELDQ INTERFACE FRAMES) collect (COPY.FRAME FRAME)))
(SETQ FIRST.FRAME (GET.FIELDQ INTERFACE FIRST.FRAME))
(SETQ REGION (COPY (GET.FIELDQ INTERFACE REGION)))
(SETQ PROFILE (COPYALL (GET.FIELDQ INTERFACE PROFILE)))
(SETQ BACKGROUND.COLOR (COPYALL (GET.FIELDQ INTERFACE BACKGROUND.COLOR)))
(SETQ NEW.INTERFACE (ITEM.CREATE INTERFACE (NAME NEW.NAME)
(FRAMES FRAMES)
(FIRST.FRAME FIRST.FRAME)
(REGION REGION)
(PROFILE PROFILE)
(BACKGROUND.COLOR BACKGROUND.COLOR)
(COLOR.MAP.INTENSITIES COLOR.MAP.INTENSITIES)))
(ADD.NEW.INTERFACE NEW.INTERFACE)
(MARK.INTERFACE NEW.INTERFACE T)
(RETURN NEW.NAME])
(COPY.INTERFACE
[LAMBDA (INTERFACE) (* kkm "19-Nov-84 12:50")
(PROG (NAME NEW.NAME NEW.INTERFACE FRAMES FIRST.FRAME REGION PROFILE BACKGROUND.COLOR)
(SETQ NAME (GET.FIELDQ INTERFACE NAME INTERFACE))
(TRILLIUM.PRINTOUT ON TRILLIUM.TRACE "Copying interface " NAME)
(TRILLIUM.PRINTOUT ON PROMPTWINDOW "Name of copy: ")
(SETQ NEW.NAME (PROMPT.READ))
(COND
((NULL NEW.NAME)
(TRILLIUM.PRINTOUT ON TRILLIUM.WARNINGS "Copy command aborted"))
((NOT (ATOM NEW.NAME))
(TRILLIUM.PRINTOUT ON TRILLIUM.WARNINGS "Name must be one word")
(RETURN))
((FIND.INTERFACE NEW.NAME)
(TRILLIUM.PRINTOUT ON TRILLIUM.WARNINGS "The name " NEW.NAME " is already in use")
(RETURN))
(T (SETQ FRAMES (for FRAME in (GET.FIELDQ INTERFACE FRAMES) collect (COPY.FRAME FRAME)))
(SETQ FIRST.FRAME (GET.FIELDQ INTERFACE FIRST.FRAME))
(SETQ REGION (COPY (GET.FIELDQ INTERFACE REGION)))
(SETQ PROFILE (COPYALL (GET.FIELDQ INTERFACE PROFILE)))
(SETQ BACKGROUND.COLOR (COPYALL (GET.FIELDQ INTERFACE BACKGROUND.COLOR)))
(SETQ NEW.INTERFACE (ITEM.CREATE INTERFACE (NAME NEW.NAME)
(FRAMES FRAMES)
(FIRST.FRAME FIRST.FRAME)
(REGION REGION)
(PROFILE PROFILE)
(BACKGROUND.COLOR BACKGROUND.COLOR)))
(ADD.NEW.INTERFACE NEW.INTERFACE)
(MARK.INTERFACE NEW.INTERFACE T)
(RETURN NEW.NAME])
)
(* * Webster fixes to Trillium source)
(* * ACQUIRE.INTERFACE.NAME; Modified to inform user when no interfaces have been loaded)
(DEFINEQ
(ACQUIRE.INTERFACE.NAME.Original
[LAMBDA NIL (* DAHJr "18-JAN-83 14:46")
(DECLARE (GLOBALVARS INTERFACES))
(MENU (create MENU
ITEMS ← INTERFACES
TITLE ← "Interfaces"
CENTERFLG ← T
CHANGEOFFSETFLG ← T])
(ACQUIRE.INTERFACE.NAME
[LAMBDA NIL (* PH "18-Dec-84 16:23")
(* * Changed to print out a message if there are no interfaces in the system)
(DECLARE (GLOBALVARS INTERFACES))
(COND
(INTERFACES (MENU (create MENU
ITEMS ← INTERFACES
TITLE ← "Interfaces"
CENTERFLG ← T
CHANGEOFFSETFLG ← T)))
(T (TRILLIUM.PRINTOUT T "No interfaces!" T])
)
(* * PARC fixes to Trillium source)
(* * SET.TRILLIUM.FILES.LOCATION modified to include only host and release directory, and to
end with >)
(DEFINEQ
(SET.TRILLIUM.FILES.LOCATION.Original
[LAMBDA (FILE)
(DECLARE (GLOBALVARS TRILLIUM.DIRECTORY TRILLIUM.HOST))
(PROG ((UPFN (UNPACKFILENAME FILE)))
(SETQ TRILLIUM.HOST (LISTGET UPFN (QUOTE HOST)))
(SETQ TRILLIUM.DIRECTORY (LISTGET UPFN (QUOTE DIRECTORY])
(SET.TRILLIUM.FILES.LOCATION
[LAMBDA (FILE)
(DECLARE (GLOBALVARS TRILLIUM.DIRECTORY TRILLIUM.HOST TRILLIUM.SOURCE.SUBDIRECTORY))
(* NHB "17-Dec-84 13:38")
(PROG ((UPFN (UNPACKFILENAME FILE))
SOURCEDIR? SOURCEDIRLENGTH)
(SETQ TRILLIUM.HOST (LISTGET UPFN (QUOTE HOST)))
(SETQ TRILLIUM.DIRECTORY (LISTGET UPFN (QUOTE DIRECTORY)))
(SETQ SOURCEDIRLENGTH (LENGTH (UNPACK TRILLIUM.SOURCE.SUBDIRECTORY)))
(SETQ SOURCEDIR? (SUBSTRING TRILLIUM.DIRECTORY (MINUS SOURCEDIRLENGTH)))
(COND
((EQ (MKATOM SOURCEDIR?)
TRILLIUM.SOURCE.SUBDIRECTORY)
(SETQ TRILLIUM.DIRECTORY (MKATOM (SUBSTRING TRILLIUM.DIRECTORY 1 (DIFFERENCE -1
SOURCEDIRLENGTH])
)
(* * TRILLIUM.MAKESYS modified to cause fix file loading when sysout is restarted)
(DEFINEQ
(TRILLIUM.MAKESYS.Original
[LAMBDA (BIGSYSFLG SYSFILESPEC) (* NHB "17-Dec-84 13:29")
(DECLARE (GLOBALVARS ADVISEDFNS AFTERSYSOUTFORMS CHANGESARRAY FILELST INTERFACES NOTCOMPILEDFILES
NOTLISTEDFILES \CONNECTED.DIR \CONNECTED.HOST))
(PROG [(MAKESYSFILE (PACKFILENAME (QUOTE HOST)
(OR (FILENAMEFIELD SYSFILESPEC (QUOTE HOST))
\CONNECTED.HOST)
(QUOTE DIRECTORY)
(OR (FILENAMEFIELD SYSFILESPEC (QUOTE DIRECTORY))
\CONNECTED.DIR)
(QUOTE NAME)
(COND
((FILENAMEFIELD SYSFILESPEC (QUOTE NAME)))
(BIGSYSFLG (QUOTE BIGTRILLIUM))
(T (QUOTE TRILLIUM)))
(QUOTE EXTENSION)
(OR (FILENAMEFIELD SYSFILESPEC (QUOTE EXTENSION))
(QUOTE SYSOUT))
(QUOTE VERSION)
(OR (FILENAMEFIELD SYSFILESPEC (QUOTE VERSION))
1]
(OR (TTYCONFIRM (CONCAT "Makesys into " MAKESYSFILE " [confirm] "))
(RETURN))
(FILES?)
[COND
([OR NOTCOMPILEDFILES (FILEPKGCHANGES)
(for F in FILELST thereis (CDR (GETPROP F (QUOTE FILE]
(OR (TTYCONFIRM "You have made changes which have not been filed! Continue makesys? ")
(RETURN]
[COND
((TTYCONFIRM "Reset interfaces? ")
(for INTERFACE.NAME in INTERFACES do (RESET.INTERFACE (FIND.INTERFACE INTERFACE.NAME)
T]
[COND
[(AND (NOT BIGSYSFLG)
(TTYCONFIRM "Gain space? ")
(TTYCONFIRM "For sure? "))
(%. ERASE)
[for F in FILELST do (RPLACD (GETPROP F (QUOTE FILE]
(CLEARFILEPKG (QUOTE E))
(CLRHASH CHANGESARRAY)
(CLRHASH)
(SETQ ADVISEDFNS)
(MAPATOMS (FUNCTION (LAMBDA (X)
(REMPROPLIST X
(QUOTE (VALUE EXPR CODE SUBR FILEMAP ADVISED ADVICE READVICE
EDIT-SAVE *HISTORY*]
(T (MAPATOMS (FUNCTION (LAMBDA (X)
(REMPROPLIST X (QUOTE (VALUE CODE SUBR EDIT-SAVE *HISTORY*]
(* * Let MAKESYS worry about this: (SETQ GREETHIST))
(SETQ NOTLISTEDFILES)
(PURGEHISTORY (QUOTE E))
(REMPROP (QUOTE EDIT)
(QUOTE LASTVALUE))
(RESETDEDIT)
[OR (FASSOC (QUOTE TRILLIUM.INIT)
AFTERSYSOUTFORMS)
(NCONC1 AFTERSYSOUTFORMS (QUOTE (TRILLIUM.INIT]
(RECLAIM)
(MAKESYS MAKESYSFILE])
(TRILLIUM.MAKESYS
[LAMBDA (BIGSYSFLG SYSFILESPEC) (* NHB "17-Dec-84 17:31")
(* Fixed by NHB to handle null connected directory)
(DECLARE (GLOBALVARS ADVISEDFNS POSTGREETFORMS CHANGESARRAY FILELST INTERFACES NOTCOMPILEDFILES
NOTLISTEDFILES \CONNECTED.DIR \CONNECTED.HOST))
(PROG [(MAKESYSFILE (PACKFILENAME (QUOTE HOST)
(OR (FILENAMEFIELD SYSFILESPEC (QUOTE HOST))
\CONNECTED.HOST)
(QUOTE DIRECTORY)
(OR (FILENAMEFIELD SYSFILESPEC (QUOTE DIRECTORY))
(AND (NOT (STREQUAL \CONNECTED.DIR ""))
\CONNECTED.DIR))
(QUOTE NAME)
(COND
((FILENAMEFIELD SYSFILESPEC (QUOTE NAME)))
(BIGSYSFLG (QUOTE BIGTRILLIUM))
(T (QUOTE TRILLIUM)))
(QUOTE EXTENSION)
(OR (FILENAMEFIELD SYSFILESPEC (QUOTE EXTENSION))
(QUOTE SYSOUT))
(QUOTE VERSION)
(OR (FILENAMEFIELD SYSFILESPEC (QUOTE VERSION))
1]
(OR (TTYCONFIRM (CONCAT "Makesys into " MAKESYSFILE " [confirm] "))
(RETURN))
(FILES?)
[COND
([OR NOTCOMPILEDFILES (FILEPKGCHANGES)
(for F in FILELST thereis (CDR (GETPROP F (QUOTE FILE]
(OR (TTYCONFIRM "You have made changes which have not been filed! Continue makesys? ")
(RETURN]
[COND
((TTYCONFIRM "Reset interfaces? ")
(for INTERFACE.NAME in INTERFACES do (RESET.INTERFACE (FIND.INTERFACE INTERFACE.NAME)
T]
[COND
[(AND (NOT BIGSYSFLG)
(TTYCONFIRM "Gain space? ")
(TTYCONFIRM "For sure? "))
(%. ERASE)
[for F in FILELST do (RPLACD (GETPROP F (QUOTE FILE]
(CLEARFILEPKG (QUOTE E))
(CLRHASH CHANGESARRAY)
(CLRHASH)
(SETQ ADVISEDFNS)
(MAPATOMS (FUNCTION (LAMBDA (X)
(REMPROPLIST X
(QUOTE (VALUE EXPR CODE SUBR FILEMAP ADVISED ADVICE READVICE
EDIT-SAVE *HISTORY*]
(T (MAPATOMS (FUNCTION (LAMBDA (X)
(REMPROPLIST X (QUOTE (VALUE CODE SUBR EDIT-SAVE *HISTORY*]
(* * Let MAKESYS worry about this: (SETQ GREETHIST))
(SETQ NOTLISTEDFILES)
(PURGEHISTORY (QUOTE E))
(REMPROP (QUOTE EDIT)
(QUOTE LASTVALUE))
(RESETDEDIT)
[OR (FASSOC (QUOTE TRILLIUM.LOAD.FIXES)
POSTGREETFORMS)
(NCONC1 POSTGREETFORMS (QUOTE (TRILLIUM.LOAD.FIXES]
[OR (FASSOC (QUOTE PROFILE.INIT)
POSTGREETFORMS)
(NCONC1 POSTGREETFORMS (QUOTE (PROFILE.INIT]
(RECLAIM)
(MAKESYS MAKESYSFILE])
)
(* * TRILLIUM.SET.SOURCE modified to make use of new var TRILLIUM.SOURCE.SUBDIRECTORY)
(DEFINEQ
(TRILLIUM.SET.SOURCE.Original
[LAMBDA (FILE) (* NHB "17-Dec-84 12:26")
(DECLARE (GLOBALVARS TRILLIUM.DIRECTORY TRILLIUM.HOST))
(CDR (RPLACD (CAR (GETPROP FILE (QUOTE FILEDATES)))
(PACKFILENAME (QUOTE HOST)
TRILLIUM.HOST
(QUOTE DIRECTORY)
TRILLIUM.DIRECTORY
(QUOTE NAME)
FILE])
(TRILLIUM.SET.SOURCE
[LAMBDA (FILE SUBDIRECTORY) (* edited: "18-Jan-85 13:45")
(DECLARE (GLOBALVARS TRILLIUM.DIRECTORY TRILLIUM.HOST))
(CDR (RPLACD (CAR (GETPROP FILE (QUOTE FILEDATES)))
(PACKFILENAME (QUOTE HOST)
TRILLIUM.HOST
(QUOTE DIRECTORY)
(CONCAT TRILLIUM.DIRECTORY (OR SUBDIRECTORY
TRILLIUM.SOURCE.SUBDIRECTORY))
(QUOTE NAME)
FILE])
)
(* * TRILLIUM.LOAD.FIXES new function to do work of loading all fix files)
(DEFINEQ
(TRILLIUM.LOAD.FIXES
[LAMBDA NIL (* edited: "19-Dec-84 15:36")
(* NHB "17-Dec-84 17:12")
(* load all the fix files we can find from the fixes
subdirectory)
(DECLARE (GLOBALVARS TRILLIUM.FIX.SUBDIRECTORY))
(PROG (FIX-FILES)
(SETQ FIX-FILES (DIRECTORY (TRILLIUM.FILENAME (QUOTE *)
T TRILLIUM.FIX.SUBDIRECTORY)))
[MAPC FIX-FILES (FUNCTION (LAMBDA (FILE)
(COND
((INFILEP FILE)
(LOAD FILE]
(COND
((GETPROP (QUOTE TRILLIUM.INIT)
(QUOTE EXPR))
(SETQ FIX-FILES (DIRECTORY (TRILLIUM.FILENAME (QUOTE *.;)
NIL TRILLIUM.FIX.SUBDIRECTORY)))
(MAPC FIX-FILES (FUNCTION (LAMBDA (FILE)
(COND
((INFILEP FILE)
(LOAD FILE (QUOTE ALLPROP])
)
(* * TRILLIUM.LOAD.TRILLIUM? modified to make use of modified TRILLIUM.FILENAME)
(DEFINEQ
(TRILLIUM.LOAD.TRILLIUM?.Original
[LAMBDA NIL (* kkm "26-Nov-84 11:44")
(* DAHJr " 5-DEC-83 09:17")
(* Load the Trillium system unless TRILLIUM.LOADED has
a value.)
(DECLARE (GLOBALVARS TRILLIUM.FILES TRILLIUM.LOADED))
(COND
((NOT (BOUNDP (QUOTE TRILLIUM.LOADED)))
(PROG (SOURCES? SOURCEONLY? SYSONLY? STANDARD? DEMO? (TRIFILES (REMOVE (QUOTE TRI-ITEMTYPES)
TRILLIUM.FILES)))
(SETQ TRILLIUM.LOADED T) (* So we can recursively load sources of TRILLIUM
file.)
(printout T T "Loading the TRILLIUM system ..." T)
(SETQ SYSONLY? (EQ (ASKUSER NIL NIL " Small loadup? ")
(QUOTE Y)))
[COND
((NOT SYSONLY?)
(SETQ TRIFILES (CONS (QUOTE TRI-TOOLS)
TRIFILES))
(SETQ SOURCES? (EQ (ASKUSER NIL NIL " Load sources? ")
(QUOTE Y)))
(COND
(SOURCES? (SETQ SOURCEONLY? (EQ (ASKUSER NIL NIL " Load sources only? ")
(QUOTE Y]
(SETQ STANDARD? (EQ (ASKUSER NIL NIL " Load standard set of item types? ")
(QUOTE Y)))
(SETQ DEMO? (EQ (ASKUSER NIL NIL " Load DEMO interface? ")
(QUOTE Y)))
(printout NIL T "Loading Trillium files: ")
(for FILE in (SETQ TRIFILES (SORT (COPY TRIFILES))) do (printout NIL T 3 FILE))
(printout NIL T T "Go ahead and have some coffee!" T)
(printout NIL 3 "(Don't forget to hit the SPACE bar a few times!)" T)
[COND
((AND SOURCES? (NOT SOURCEONLY?))
(LOAD (TRILLIUM.FILENAME (QUOTE TRILLIUM))
(QUOTE ALLPROP]
(FILESLOAD (SYSLOAD FROM VALUEOF LISPUSERSDIRECTORIES)
COMPILEBANG EDITBITMAP GRAPHER HEADLINE MAKEGRAPH READNUMBER TEDIT
TRAJECTORY-FOLLOWER PIECE-MENUS)
[for F in TRIFILES do (COND
(SOURCEONLY? (LOAD (TRILLIUM.FILENAME F)))
(T (LOAD (TRILLIUM.FILENAME F T)
(AND SYSONLY? (QUOTE SYSLOAD)))
(COND
(SOURCES? (LOAD (TRILLIUM.FILENAME F)
(QUOTE ALLPROP]
(LOAD (TRILLIUM.FILENAME (QUOTE TRI-ITEMTYPES))
(AND SYSONLY? (QUOTE SYSLOAD)))
(TRILLIUM.INIT)
(TRILLIUM (create POSITION
XCOORD ← 730
YCOORD ← 330))
[COND
(STANDARD? (for F in (QUOTE (PRIMITIVE-ITEMTYPES COMPOSITE-ITEMTYPES))
do (LOAD (TRILLIUM.ITEMTYPES.FILENAME F)
(AND SYSONLY? (QUOTE SYSLOAD)))
(MARK.OBJECT.FILE F))
(LOAD (TRILLIUM.PTYPES.FILENAME (QUOTE BASIC-PTYPES))
(AND SYSONLY? (QUOTE SYSLOAD)))
(MARK.OBJECT.FILE (QUOTE BASIC-PTYPES]
[COND
(DEMO? (LOAD (TRILLIUM.FILENAME (QUOTE DEMO-INTERFACE))
(AND SYSONLY? (QUOTE SYSLOAD)))
(MARK.OBJECT.FILE (QUOTE DEMO-INTERFACE]
(COMPILE.INTERNAL.FNS.IF.NECESSARY)
(RETURN T])
(TRILLIUM.LOAD.TRILLIUM?
[LAMBDA NIL (* N.H.Briggs "18-Jan-85 14:58")
(* DAHJr " 5-DEC-83 09:17")
(* Load the Trillium system unless TRILLIUM.LOADED has
a value.)
(DECLARE (GLOBALVARS TRILLIUM.FILES TRILLIUM.LOADED TRILLIUM.ITEMTYPE.SUBDIRECTORY
TRILLIUM.PTYPE.SUBDIRECTORY TRILLIUM.INTERFACE.SUBDIRECTORY))
(COND
((NOT (BOUNDP (QUOTE TRILLIUM.LOADED)))
(PROG (SOURCES? SOURCEONLY? SYSONLY? STANDARD? DEMO? (TRIFILES (REMOVE (QUOTE TRI-ITEMTYPES)
TRILLIUM.FILES)))
(SETQ TRILLIUM.LOADED T) (* So we can recursively load sources of TRILLIUM
file.)
(printout T T "Loading the TRILLIUM system ..." T)
(SETQ SYSONLY? (EQ (ASKUSER NIL NIL " Small loadup? ")
(QUOTE Y)))
[COND
((NOT SYSONLY?)
(SETQ TRIFILES (CONS (QUOTE TRI-TOOLS)
TRIFILES))
(SETQ SOURCES? (EQ (ASKUSER NIL NIL " Load sources? ")
(QUOTE Y)))
(COND
(SOURCES? (SETQ SOURCEONLY? (EQ (ASKUSER NIL NIL " Load sources only? ")
(QUOTE Y]
(SETQ STANDARD? (EQ (ASKUSER NIL NIL " Load standard set of item types? ")
(QUOTE Y)))
(SETQ DEMO? (EQ (ASKUSER NIL NIL " Load DEMO interface? ")
(QUOTE Y)))
(printout NIL T "Loading Trillium files: ")
(for FILE in (SETQ TRIFILES (SORT (COPY TRIFILES))) do (printout NIL T 3 FILE))
(printout NIL T T "Go ahead and have some coffee!" T)
(printout NIL 3 "(Don't forget to hit the SPACE bar a few times!)" T)
[COND
((AND SOURCES? (NOT SOURCEONLY?))
(LOAD (TRILLIUM.FILENAME (QUOTE TRILLIUM))
(QUOTE ALLPROP]
(FILESLOAD (SYSLOAD FROM VALUEOF LISPUSERSDIRECTORIES)
COMPILEBANG EDITBITMAP GRAPHER HEADLINE MAKEGRAPH READNUMBER TEDIT
TRAJECTORY-FOLLOWER PIECE-MENUS)
(for F in TRIFILES
do [COND
(SOURCEONLY? (LOAD (TRILLIUM.FILENAME F)))
(T (LOAD (TRILLIUM.FILENAME F T)
(AND SYSONLY? (QUOTE SYSLOAD)))
(COND
(SOURCES? (LOAD (TRILLIUM.FILENAME F)
(QUOTE ALLPROP]
(TRILLIUM.SET.SOURCE F))
(LOAD (TRILLIUM.FILENAME (QUOTE TRI-ITEMTYPES))
(AND SYSONLY? (QUOTE SYSLOAD)))
(TRILLIUM.SET.SOURCE (QUOTE TRI-ITEMTYPES))
(TRILLIUM.INIT)
(TRILLIUM (create POSITION
XCOORD ← 730
YCOORD ← 330))
[COND
(STANDARD? (for F in (QUOTE (PRIMITIVE-ITEMTYPES COMPOSITE-ITEMTYPES))
do (LOAD (TRILLIUM.FILENAME F NIL TRILLIUM.ITEMTYPE.SUBDIRECTORY)
(AND SYSONLY? (QUOTE SYSLOAD)))
(TRILLIUM.SET.SOURCE F TRILLIUM.ITEMTYPE.SUBDIRECTORY)
(MARK.OBJECT.FILE F))
(LOAD (TRILLIUM.FILENAME (QUOTE BASIC-PTYPES)
NIL TRILLIUM.PTYPE.SUBDIRECTORY)
(AND SYSONLY? (QUOTE SYSLOAD)))
(TRILLIUM.SET.SOURCE (QUOTE BASIC-PTYPES)
TRILLIUM.PTYPE.SUBDIRECTORY)
(MARK.OBJECT.FILE (QUOTE BASIC-PTYPES]
[COND
(DEMO? (LOAD (TRILLIUM.FILENAME (QUOTE DEMO-INTERFACE)
NIL TRILLIUM.INTERFACE.SUBDIRECTORY)
(AND SYSONLY? (QUOTE SYSLOAD)))
(TRILLIUM.SET.SOURCE (QUOTE DEMO-INTERFACE)
TRILLIUM.INTERFACE.SUBDIRECTORY)
(MARK.OBJECT.FILE (QUOTE DEMO-INTERFACE]
(COMPILE.INTERNAL.FNS.IF.NECESSARY)
(RETURN T])
)
(* * TRILLIUM.FILENAME modified to take argument indicating which subdirectory of the release
to take file from)
(DEFINEQ
(TRILLIUM.FILENAME.Original
[LAMBDA (FILE COMPILED) (* edited: "18-SEP-82 09:52")
(DECLARE (GLOBALVARS COMPILE.EXT TRILLIUM.DIRECTORY TRILLIUM.HOST))
(COND
(COMPILED (PACKFILENAME (QUOTE HOST)
TRILLIUM.HOST
(QUOTE DIRECTORY)
TRILLIUM.DIRECTORY
(QUOTE NAME)
FILE
(QUOTE EXTENSION)
COMPILE.EXT))
(T (PACKFILENAME (QUOTE HOST)
TRILLIUM.HOST
(QUOTE DIRECTORY)
TRILLIUM.DIRECTORY
(QUOTE NAME)
FILE])
(TRILLIUM.FILENAME
[LAMBDA (FILE COMPILED SUBDIRECTORY) (* NHB "17-Dec-84 13:20")
(DECLARE (GLOBALVARS COMPILE.EXT TRILLIUM.DIRECTORY TRILLIUM.HOST TRILLIUM.SOURCE.SUBDIRECTORY))
(PROG [(DIRECTORY (COND
(SUBDIRECTORY (CONCAT TRILLIUM.DIRECTORY SUBDIRECTORY))
(T (CONCAT TRILLIUM.DIRECTORY TRILLIUM.SOURCE.SUBDIRECTORY]
(RETURN (COND
(COMPILED (PACKFILENAME (QUOTE HOST)
TRILLIUM.HOST
(QUOTE DIRECTORY)
DIRECTORY
(QUOTE NAME)
FILE
(QUOTE EXTENSION)
COMPILE.EXT))
(T (PACKFILENAME (QUOTE HOST)
TRILLIUM.HOST
(QUOTE DIRECTORY)
DIRECTORY
(QUOTE NAME)
FILE])
)
(* * TRILLIUM.RELEASE.HOST/DIRECTORY Obsolete variable, set to NOBIND)
(RPAQQ TRILLIUM.RELEASE.HOST/DIRECTORY NOBIND)
(* * *.SUBDIRECTORY new (global) variables locating the subdirectories wherein various parts of
Trillium are kept)
(RPAQQ TRILLIUM.SOURCE.SUBDIRECTORY SOURCES)
(RPAQQ TRILLIUM.PTYPE.SUBDIRECTORY PTYPES)
(RPAQQ TRILLIUM.ITEMTYPE.SUBDIRECTORY ITEMTYPES)
(RPAQQ TRILLIUM.FIX.SUBDIRECTORY FIXES)
(RPAQQ TRILLIUM.INTERFACE.SUBDIRECTORY INTERFACES)
(* * add itemtype and ptype to the list of objects included in a LISTFILE index)
(ADDTOVAR INDEXEDTYPESLST (ITEMTYPE READ.ITEMTYPE)
(PTYPE READ.PTYPE))
(* * MAKE.ITEMTYPES.COMS and MAKE.PTYPES.COMS now add a comment giving name of object)
(DEFINEQ
(MAKE.ITEMTYPES.COMS.Original
[NLAMBDA (ITYPES) (* DAHJr "14-APR-83 21:22")
(for ITYPE in ITYPES bind (DESCRIPTION OTHER FNS)
join (SETQ DESCRIPTION (ITEM.TYPE.DESCRIPTION ITYPE))
(SETQ OTHER (GET.FIELDQ DESCRIPTION OTHER ITEM.TYPE))
(SETQ FNS (for FN in (LISTGET OTHER (QUOTE FNS)) collect (CADR FN)))
(CONS (LIST (QUOTE E)
(LIST (QUOTE DUMP.ITEMTYPE)
(KWOTE ITYPE)))
(AND FNS (LIST (CONS (QUOTE FNS)
FNS])
(MAKE.ITEMTYPES.COMS
[NLAMBDA (ITYPES) (* edited: " 7-Jan-85 15:45")
(for ITYPE in ITYPES bind (DESCRIPTION OTHER FNS)
join (SETQ DESCRIPTION (ITEM.TYPE.DESCRIPTION ITYPE))
(SETQ OTHER (GET.FIELDQ DESCRIPTION OTHER ITEM.TYPES))
(SETQ FNS (for FN in (LISTGET OTHER (QUOTE FNS)) collect (CADR FN)))
(CONS (LIST (QUOTE *)
ITYPE)
(CONS (LIST (QUOTE E)
(LIST (QUOTE DUMP.ITEMTYPE)
(KWOTE ITYPE)))
(AND FNS (LIST (CONS (QUOTE FNS)
FNS])
(MAKE.PTYPES.COMS.Original
[NLAMBDA (PTYPES) (* N.H.Briggs "18-Jan-85 15:12")
(for PTYPE in PTYPES bind (DESCRIPTION OTHER FNS)
join (SETQ DESCRIPTION (PTYPE.DESCRIPTION PTYPE))
(SETQ OTHER (GET.FIELDQ DESCRIPTION OTHER))
(SETQ FNS (for FN in (LISTGET OTHER (QUOTE FNS)) collect (CADR FN)))
(CONS (LIST (QUOTE E)
(LIST (QUOTE DUMP.PTYPE)
(KWOTE PTYPE)))
(AND FNS (LIST (CONS (QUOTE FNS)
FNS])
(MAKE.PTYPES.COMS
[NLAMBDA (PTYPES) (* N.H.Briggs "18-Jan-85 15:05")
(for PTYPE in PTYPES bind (DESCRIPTION OTHER FNS)
join (SETQ DESCRIPTION (PTYPE.DESCRIPTION PTYPE))
(SETQ OTHER (GET.FIELDQ DESCRIPTION OTHER))
(SETQ FNS (for FN in (LISTGET OTHER (QUOTE FNS)) collect (CADR FN)))
(CONS (LIST (QUOTE *)
PTYPE)
(CONS (LIST (QUOTE E)
(LIST (QUOTE DUMP.PTYPE)
(KWOTE PTYPE)))
(AND FNS (LIST (CONS (QUOTE FNS)
FNS])
)
(* * LIST.OBJECTS.ON.FILE mustn't delete file before LISTFILES is finished)
(DEFINEQ
(LIST.OBJECTS.ON.FILE.Original
[LAMBDA (FILENAME) (* HaKo "16-Aug-84 16:29")
(DECLARE (GLOBALVARS TRILLIUM.OBJECT.FILES))
(PROG (ENTRY CONTENTS INTERFACE.NAMES ITEMTYPE.NAMES FN INTERFACE)
(SETQ ENTRY (FASSOC FILENAME TRILLIUM.OBJECT.FILES))
(SETQ CONTENTS (CDR ENTRY))
(SETQ FN (PACKFILENAME (QUOTE HOST)
(QUOTE CORE)
(QUOTE NAME)
FILENAME
(QUOTE EXTENSION)
(QUOTE TXT)
(QUOTE VERSION)
1))
(TRILLIUM.PRINTOUT ON TRILLIUM.TRACE "Making the file ...")
(OPENFILE FN (QUOTE OUTPUT))
(printout FN "A printout of " FILENAME ", a file of Trillium objects." T "As of " (DATE)
", has contents as follows:")
(printout FN T)
(printout FN T)
(printout FN "Interfaces:")
(SETQ INTERFACE.NAMES (LISTGET CONTENTS (QUOTE INTERFACE.NAMES)))
(COND
(INTERFACE.NAMES (for INTERFACE.NAME in INTERFACE.NAMES do (printout FN " "
INTERFACE.NAME)))
(T (printout FN " none")))
(printout FN T)
(printout FN T)
(printout FN "Itemtypes:")
(SETQ ITEMTYPE.NAMES (LISTGET CONTENTS (QUOTE ITEMTYPE.NAMES)))
(COND
(ITEMTYPE.NAMES (for ITEMTYPE.NAME in ITEMTYPE.NAMES do (printout FN " " ITEMTYPE.NAME)))
(T (printout FN " none")))
(printout FN T)
(printout FN T)
(for INTERFACE.NAME in INTERFACE.NAMES
do (SETQ INTERFACE (FIND.INTERFACE INTERFACE.NAME))
(RESET.INTERFACE INTERFACE T)
(PRINTDEF INTERFACE NIL NIL NIL NIL FN)
(printout FN T)
(printout FN T))
(for ITEMTYPE.NAME in ITEMTYPE.NAMES
do (PRINTDEF (ITEM.TYPE.DESCRIPTION ITEMTYPE.NAME)
NIL NIL NIL NIL FN)
(printout FN T)
(printout FN T))
(CLOSEF FN)
(TRILLIUM.PRINTOUT ON TRILLIUM.TRACE SAME.LINE "listing the file ...")
(APPLY* (QUOTE LISTFILES)
FN)
(TRILLIUM.PRINTOUT ON TRILLIUM.TRACE SAME.LINE "done")
(DELFILE FN])
(LIST.OBJECTS.ON.FILE
[LAMBDA (FILENAME) (* N.H.Briggs "18-Jan-85 17:59")
(* * fixed to spawn a process with \SINGLEFILEINDEX.DONTSPAWN bound to T to avoid deleting listing file before
LISTFILES process has finished)
(DECLARE (GLOBALVARS TRILLIUM.OBJECT.FILES))
(PROG (ENTRY CONTENTS INTERFACE.NAMES ITEMTYPE.NAMES FN INTERFACE)
(SETQ ENTRY (FASSOC FILENAME TRILLIUM.OBJECT.FILES))
(SETQ CONTENTS (CDR ENTRY))
(SETQ FN (PACKFILENAME (QUOTE HOST)
(QUOTE CORE)
(QUOTE NAME)
FILENAME
(QUOTE EXTENSION)
(QUOTE TXT)
(QUOTE VERSION)
1))
(TRILLIUM.PRINTOUT ON TRILLIUM.TRACE "Making the file ...")
(OPENFILE FN (QUOTE OUTPUT))
(printout FN "A printout of " FILENAME ", a file of Trillium objects." T "As of " (DATE)
", has contents as follows:")
(printout FN T)
(printout FN T)
(printout FN "Interfaces:")
(SETQ INTERFACE.NAMES (LISTGET CONTENTS (QUOTE INTERFACE.NAMES)))
(COND
(INTERFACE.NAMES (for INTERFACE.NAME in INTERFACE.NAMES do (printout FN " "
INTERFACE.NAME)))
(T (printout FN " none")))
(printout FN T)
(printout FN T)
(printout FN "Itemtypes:")
(SETQ ITEMTYPE.NAMES (LISTGET CONTENTS (QUOTE ITEMTYPE.NAMES)))
(COND
(ITEMTYPE.NAMES (for ITEMTYPE.NAME in ITEMTYPE.NAMES do (printout FN " " ITEMTYPE.NAME)))
(T (printout FN " none")))
(printout FN T)
(printout FN T)
(for INTERFACE.NAME in INTERFACE.NAMES
do (SETQ INTERFACE (FIND.INTERFACE INTERFACE.NAME))
(RESET.INTERFACE INTERFACE T)
(PRINTDEF INTERFACE NIL NIL NIL NIL FN)
(printout FN T)
(printout FN T))
(for ITEMTYPE.NAME in ITEMTYPE.NAMES
do (PRINTDEF (ITEM.TYPE.DESCRIPTION ITEMTYPE.NAME)
NIL NIL NIL NIL FN)
(printout FN T)
(printout FN T))
(CLOSEF FN)
(ADD.PROCESS (BQUOTE (PROGN (RESETVAR \SINGLEFILEINDEX.DONTSPAWN T (LISTFILES , FN))
(DELFILE (QUOTE , FN))
(TRILLIUM.PRINTOUT ON TRILLIUM.TRACE "Listing of "
(QUOTE , FILENAME)
" complete.")))
(QUOTE NAME)
(QUOTE Trillium% Listing))
(TRILLIUM.PRINTOUT ON TRILLIUM.TRACE SAME.LINE " spawned listing process."])
)
(* * fixes to Trillium Itemtypes and Ptypes)
(* * LABELLED.BUTTON Changed default LABEL value to be "1" instead of 1)
(* LABELLED.BUTTON)
(READ.ITEMTYPE LABELLED.BUTTON 5)
(\TYPE ITEM.TYPE NAME LABELLED.BUTTON COMMENT
"A button, with a label centered on it, which flashes when pushed, and performs an action" KIND
COMPOSITE PARAMETERS ((\TYPE PARAMETER NAME PLACEMENT TYPE (POSITION) DEFAULT (170 . 170) COMMENT
"The grid position of the lower left corner of the button" GRID.TYPE (LOCATION)) (\TYPE PARAMETER
NAME LABEL TYPE (STRING) DEFAULT "1" COMMENT "The words on the button") (\TYPE PARAMETER NAME FONT
TYPE (FONT) DEFAULT NIL COMMENT "The font for the button label") (\TYPE PARAMETER NAME ACTION.FORM
TYPE (FORM) DEFAULT (ACTION.PRINT "This action brought to you by a LABELLED.BUTTON") COMMENT
"The action caused by this button") (\TYPE PARAMETER NAME PICTURE TYPE (BITMAP.NAME) DEFAULT
SIMPLE.BUTTON.BITMAP COMMENT "The graphic for the button")) SUBITEM.SPECS ((LABEL BUTTON (ITEM
PICTURE (PLACEMENT (PTRANSLATE PLACEMENT (NEW.POSITION (MINUS BUTTON.BITMAP.EXTRA) 0))) (BITMAP
PICTURE))) (ITEM LINE.OF.TEXT (PLACEMENT (PICTURE.CENTER BUTTON)) (LINE LABEL) (XALIGNMENT (
QUOTE CENTER)) (FONT FONT)) (ITEM FLASHING.SENSITIVE.REGION (PLACEMENT (BOUNDING.BOX BUTTON)) (
ACTION.FORM ACTION.FORM))) CLASSES (COMPOSITE BUTTON))
(* * INVERTING.CASCADE.LIGHT alignment values were inadvertently quoted: D.Ingalls)
(* INVERTING.CASCADE.LIGHT)
(READ.ITEMTYPE INVERTING.CASCADE.LIGHT 5)
(\TYPE ITEM.TYPE NAME INVERTING.CASCADE.LIGHT COMMENT "An indicator with associated text" KIND
COMPOSITE PARAMETERS ((\TYPE PARAMETER NAME PLACEMENT TYPE (POSITION) DEFAULT (170 . 170) COMMENT
"A reference grid position" GRID.TYPE (LOCATION)) (\TYPE PARAMETER NAME TEXT TYPE (LIST (STRING))
DEFAULT (Label for Light) COMMENT "The text associated with the light") (\TYPE PARAMETER NAME FONT
TYPE (FONT) DEFAULT (HELVETICA 10) COMMENT "The font in which to print the information") (\TYPE
PARAMETER NAME TEXT.OFFSET TYPE (OFFSET.VECTOR (PLACEMENT)) DEFAULT (51 . 17) COMMENT
"The offset of the words form the lower left corner of the button") (\TYPE PARAMETER NAME
HORIZONTAL.ALIGNMENT TYPE (ONEOF (LEFT CENTER RIGHT)) DEFAULT (QUOTE LEFT) COMMENT
"Horizontal alignment of text about reference point") (\TYPE PARAMETER NAME VERTICAL.ALIGNMENT TYPE
(ONEOF (TOP CENTER BOTTOM)) DEFAULT (QUOTE CENTER) COMMENT
"Vertical alignment of text about the reference point") (\TYPE PARAMETER NAME CELL TYPE (CELL)
DEFAULT CELL.1 COMMENT "The cell to affect and display") (\TYPE PARAMETER NAME VALUE TYPE (CONSTANT
) DEFAULT VALUE.1 COMMENT "The value to be set and reflected")) SUBITEM.SPECS ((LABEL WORDS (ITEM
BLOCK.OF.TEXT (PLACEMENT (PTRANSLATE PLACEMENT TEXT.OFFSET)) (LIST.OF.LINES TEXT) (FONT FONT) (
XALIGNMENT HORIZONTAL.ALIGNMENT) (YALIGNMENT VERTICAL.ALIGNMENT))) (ITEM LIGHT (PLACEMENT (
BOUNDING.BOX WORDS)) (CELL CELL) (REFERENCE.VALUE VALUE))) OTHER (FNS ((1
CONVERT.INVERTING.CASCADE.LIGHT.OFFSETS))) CLASSES (COMPOSITE) VERSION 1)
(DEFINEQ
(CONVERT.INVERTING.CASCADE.LIGHT.OFFSETS
[LAMBDA (ITEM) (* edited: "16-Aug-84 10:07")
(CONVERT.GRIDDED.OFFSETSQ ITEM HORIZONTAL.OFFSET VERTICAL.OFFSET TEXT.OFFSET])
)
(* * Submitted by PatH: BITMAP.NAME/CREATE used (LISTGET CURRENT.FRAME.CLASSES (QUOTE
BITMAP.FRAMES)) instead of CURRENT.BITMAP.FRAMES)
(DEFINEQ
(BITMAP.NAME/CREATE.Original
[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])
)
(* BITMAP.NAME)
(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) (* edited: "11-Dec-84 09:43")
(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 (FOR FRAME IN (OR CURRENT.BITMAP.FRAMES (SET.CURRENT.BITMAP.FRAMES))
COLLECT (GET.FIELDQ FRAME NAME FRAME)))
(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])
)
(COMPILE.INTERNAL.FNS.IF.NECESSARY)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML MAKE.PTYPES.COMS MAKE.PTYPES.COMS.Original MAKE.ITEMTYPES.COMS
MAKE.ITEMTYPES.COMS.Original)
(ADDTOVAR LAMA )
)
(PUTPROPS JAN-18-85-FIXES-COMPLETE COPYRIGHT ("Xerox Corporation" 1985))
(DECLARE: DONTCOPY
(FILEMAP (NIL (4507 5508 (FONTS.IN.CORE.Original 4517 . 5015) (FONTS.IN.CORE 5017 . 5506)) (5576 7652
(FORGET.FRAME.CLASS.Original 5586 . 6603) (FORGET.FRAME.CLASS 6605 . 7650)) (7746 9648 (
MOVE.ITEM.Original 7756 . 8670) (MOVE.ITEM 8672 . 9646)) (9731 12994 (COPY.INTERFACE.Original 9741 .
11396) (COPY.INTERFACE 11398 . 12992)) (13136 13909 (ACQUIRE.INTERFACE.NAME.Original 13146 . 13444) (
ACQUIRE.INTERFACE.NAME 13446 . 13907)) (14064 15285 (SET.TRILLIUM.FILES.LOCATION.Original 14074 .
14400) (SET.TRILLIUM.FILES.LOCATION 14402 . 15283)) (15375 21101 (TRILLIUM.MAKESYS.Original 15385 .
18080) (TRILLIUM.MAKESYS 18082 . 21099)) (21195 22152 (TRILLIUM.SET.SOURCE.Original 21205 . 21640) (
TRILLIUM.SET.SOURCE 21642 . 22150)) (22234 23287 (TRILLIUM.LOAD.FIXES 22244 . 23285)) (23375 30638 (
TRILLIUM.LOAD.TRILLIUM?.Original 23385 . 26740) (TRILLIUM.LOAD.TRILLIUM? 26742 . 30636)) (30759 32189
(TRILLIUM.FILENAME.Original 30769 . 31384) (TRILLIUM.FILENAME 31386 . 32187)) (32955 35442 (
MAKE.ITEMTYPES.COMS.Original 32965 . 33568) (MAKE.ITEMTYPES.COMS 33570 . 34218) (
MAKE.PTYPES.COMS.Original 34220 . 34808) (MAKE.PTYPES.COMS 34810 . 35440)) (35525 40535 (
LIST.OBJECTS.ON.FILE.Original 35535 . 37851) (LIST.OBJECTS.ON.FILE 37853 . 40533)) (43701 43935 (
CONVERT.INVERTING.CASCADE.LIGHT.OFFSETS 43711 . 43933)) (44079 46174 (BITMAP.NAME/CREATE.Original
44089 . 46172)) (46326 48444 (BITMAP.NAME/CREATE 46336 . 48442)))))
STOP