(FILECREATED " 2-Jan-85 17:07:17" {AZTEC}<TRILLIUM>BIRTHDAY84>FIXES>TRI-FIX-HENR-FNS.;2 9443
changes to: (VARS TRI-FIX-HENR-FNSCOMS)
(FNS COPY.INTERFACE.Original)
previous date: "29-Nov-84 20:15:03" {AZTEC}<TRILLIUM>BIRTHDAY84>FIXES>TRI-FIX-HENR-FNS.;1)
(PRETTYCOMPRINT TRI-FIX-HENR-FNSCOMS)
(RPAQQ TRI-FIX-HENR-FNSCOMS ((* 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)))
(* 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 (* kkm "29-Nov-84 13:34")
(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))))))
(for FAMILY in \FONTSINCORE join (for SIZE in (CDR FAMILY)
join (for FACE in (CDR SIZE)
join (for DEVICE in (CDADR FACE)
when (EQ (CAR DEVICE)
(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])
)
(DECLARE: DONTCOPY
(FILEMAP (NIL (1221 2387 (FONTS.IN.CORE.Original 1231 . 1681) (FONTS.IN.CORE 1683 . 2385)) (2455 4391
(FORGET.FRAME.CLASS.Original 2465 . 3414) (FORGET.FRAME.CLASS 3416 . 4389)) (4485 6267 (
MOVE.ITEM.Original 4495 . 5353) (MOVE.ITEM 5355 . 6265)) (6350 9421 (COPY.INTERFACE.Original 6360 .
7919) (COPY.INTERFACE 7921 . 9419)))))
STOP